Page MenuHomeHEPForge
Files F3476943

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
Index: trunk/ChangeLog
===================================================================
--- trunk/ChangeLog (revision 8842)
+++ trunk/ChangeLog (revision 8843)
@@ -1,2325 +1,2329 @@
ChangeLog -- Summary of changes to the WHIZARD package
Use svn log to see detailed changes.
Version 3.0.3+
+2022-10-21
+ General POWHEG matching
+ with optional NLO real phase space partitioning
+
2022-06-22
POWHEG matching for Drell-Yan and similar processes
2022-05-09
Massive eikonals: Numeric robustness at ultrahigh energies
2022-04-20
Bug fix for VAMP2 event generation with indefinite samples
##################################################################
2022-04-06
RELEASE: version 3.0.3
2022-04-05
POWHEG matching for single flavor hadron collisions
2022-03-31
NLO EW processes with massless leptons and jets (i.e.
jet clustering and photon recombination) supported
NLO EW for massive initial leptons validated
2022-03-27
Complete implementation/validation of NLL electron PDFs
2022-02-22
Bug fix: correct normalization for CIRCE2+EPA+polarization
2022-02-21
WHIZARD core now uses Fortran modules and submodules
2022-01-27
Infrastructure for POWHEG matching for hadron collisions
2021-12-16
Event files can be written/read also for decay processes
Implementation of running QED coupling alpha
2021-12-10
Independent variations of renormalization/factorization scale
##################################################################
2021-11-23
RELEASE: version 3.0.2
2021-11-19
Support for a wide class of mixed NLO QCD/EW processes
2021-11-18
Add pp processes for NLO EW corrections to testsuite
2021-11-11
Output numerically critical values with LCIO 2.17+ as double
2021-11-05
Minor refactoring on phase space points and kinematics
2021-10-21
NLO (QCD) differential distributions supported for full
lepton collider setup: polarization, QED ISR, beamstrahlung
2021-10-15
SINDARIN now has a sum and product function of expressions,
SINDARIN supports observables defined on full (sub)events
First application: transverse mass
Bug fix: 2HDM did not allow H+, H- as external particles
2021-10-14
CT18 PDFs included (NLO, NNLO)
2021-09-30
Bug fix: keep non-recombined photons in the event record
2021-09-13
Modular NLO event generation with real partition
2021-08-20
Bug fix: correctly reading in NLO fixed order events
2021-08-06
Generalize optional partitioning of the NLO real phase space
##################################################################
2021-07-08
RELEASE: version 3.0.1
2021-07-06
MPI parallelization now comes with two incarnations:
- standard MPI parallelization ("simple", default)
- MPI with load balancer ("load")
2021-07-05
Bug fix for C++17 default compilers w/ HepMC3/ROOT interface
2021-07-02
Improvement for POWHEG matching:
- implement massless recoil case
- enable reading in existing POWHEG grids
- support kinematic cuts at generator level
2021-07-01
Distinguish different cases of photons in NLO EW corrections
2021-06-21
Option to keep negative PDF entries or set them zero
2021-05-31
Full LCIO MC production files can be properly recasted
2021-05-24
Use defaults for UFO models without propagators.py
2021-05-21
Bug fix: prevent invalid code for UFO models containing hyphens
2021-05-20
UFO files with scientific notation float constants allowed
UFO files: max. n-arity of vertices bound by process multiplicity
##################################################################
2021-04-27
RELEASE: version 3.0.0
2021-04-20
Minimal required OCaml version is now 4.05.0.
Bug fix for tau polarization from stau decays
2021-04-19
NLO EW splitting functions and collinear remnants completed
Photon recombination implemented
2021-04-14
Bug fix for vertices/status codes with HepMC2/3 event format
2021-04-08
Correct Lorentz statistics for UFO model with Majorana fermions
2021-04-06
Bug fix for rare script failure in system_dependencies.f90.in
Kappa factor for quartic Higgs coupling in SM_ac(_CKM) model
2021-04-04
Support for UFO extensions in SMEFTSim 3.0
2021-02-25
Enable VAMP and VAMP2 channel equivalences for NLO integrations
2021-02-04
Bug fix if user does not set a prefix at configuration
2020-12-10
Generalize NLO calculations to non-CMS lab frames
2020-12-08
Bug fix in expanded p-wave form factor for top threshold
2020-12-06
Patch for macOS Big Sur shared library handling due to libtool;
the patch also demands gcc/gfortran 11.0/10.3/9.4/8.5
2020-12-04
O'Mega only inserts non-vanishing couplings from UFO models
2020-11-21
Bug fix for fractional hypercharges in UFO models
2020-11-11
Enable PYTHIA6 settings for eh collisions (enable-pythia6_eh)
2020-11-09
Correct flavor assignment for NLO fixed-order events
2020-11-05
Bug fix for ISR handler not working with unstable particles
2020-10-08
Bug fix in LHAPDF interface for photon PDFs
2020-10-07
Bug fix for structure function setup with asymmetric beams
2020-10-02
Python/Cython layer for WHIZARD API
2020-09-30
Allow mismatches of Python and name attributes in UFO models
2020-09-26
Support for negative PDG particles from certain UFO models
2020-09-24
Allow for QNUMBERS blocks in BSM SLHA files
2020-09-22
Full support for compilation with clang(++) on Darwin/macOS
More documentation in the manual
Minor clean-ups
2020-09-16
Bug fix enables reading LCIO events with LCIO v2.15+
##################################################################
2020-09-16
RELEASE: version 2.8.5
2020-09-11
Bug fix for H->tau tau transverse polarization with PYTHIA6
(thanks to Junping Tian / Akiya Miyamoto)
2020-09-09
Fix a long standing bug (since 2.0) in the calculation of color
factors when particles of different color were combined in a
particle class. NB: O'Mega never produced a wrong number,
it only declared all processes as invalid.
2020-09-08
Enable Openloops matrix element equivalences for optimization
2020-09-02
Compatibility fix for PYTHIA v8.301+ interface
2020-09-01
Support exclusive jet clustering in ee for Fastjet interface
##################################################################
2020-08-30
RELEASE: version 3.0.0_beta
2020-08-27
Major revision of NLO distributions and events for
processes with structure functions:
- Use parton momenta/flavors (instead of beams) for events
- Bug fix for Lorentz boosts and Lorentz frames of momenta
- Bug fix: apply cuts to virtual NLO component in correct frame
- Correctly assign ISR radiation momenta in data structures
- Refactoring on quantum numbers for NLO event data structures
- Functional tests for hadron collider NLO distributions
- many minor bug fixes regarding NLO hadron collider physics
2020-08-11
Bug fix for linking problem with OpenMPI
2020-08-07
New WHIZARD API: WHIZARD can be externally linked as a
library, added examples for Fortran, C, C++ programs
##################################################################
2020-07-08
RELEASE: version 2.8.4
2020-07-07
Bug fix: steering of UFO Majorana models from WHIZARD
##################################################################
2020-07-06
Combined integration also for hadron collider processes at NLO
2020-07-05
Bug fix: correctly steer e+e- FastJet clustering algorithms
Major revision of NLO differential distributions and events:
- Correctly assign quantum numbers to NLO fixed-order events
- Correctly assign weights to NLO fixed-order events for
combined simulation
- Cut all NLO fixed-order subevents in event groups individually
- Only allow "sigma" normalization for NLO fixed-order events
- Use correct PDF setup for NLO counter events
- Several technical fixes and updates of the NLO testsuite
##################################################################
2020-07-03
RELEASE: version 2.8.3
2020-07-02
Feature-complete UFO implementation for Majorana fermions
2020-06-22
Running width scheme supported for O'Mega matrix elements
2020-06-20
Adding H-s-s coupling to SM_Higgs(_CKM) models
2020-06-17
Completion of ILC 2->6 fermion extended test suite
2020-06-15
Bug fix: PYTHIA6/Tauola, correctly assign tau spins for stau decays
2020-06-09
Bug fix: correctly update calls for additional VAMP/2 iterations
Bug fix: correct assignment for tau spins from PYTHIA6 interface
2020-06-04
Bug fix: cascades2 tree merge with empty subtree(s)
2020-05-31
Switch $epa_mode for different EPA implementations
2020-05-26
Bug fix: spin information transferred for resonance histories
2020-04-13
HepMC: correct weighted events for non-xsec event normalizations
2020-04-04
Improved HepMC3 interface: HepMC3 Root/RootTree interface
2020-03-24
ISR: Fix on-shell kinematics for events with ?isr_handler=true
(set ?isr_handler_keep_mass=false for old behavior)
2020-03-11
Beam masses are correctly passed to hard matrix element for CIRCE2
EPA with polarized beams: double-counting corrected
##################################################################
2020-03-03
RELEASE: version 3.0.0_alpha
2020-02-25
Bug fix: Scale and alphas can be retrieved from internal event format to
external formats
2020-02-17
Bug fix: ?keep_failed_events now forces output of actual event data
Bug fix: particle-set reconstruction (rescanning events w/o radiation)
2020-01-28
Bug fix for left-over EPA parameter epa_e_max (replaced by epa_q_max)
2020-01-23
Bug fix for real components of NLO QCD 2->1 processes
2020-01-22
Bug fix: correct random number sequencing during parallel MPI event
generation with rng_stream
2020-01-21
Consistent distribution of events during parallel MPI event generation
2020-01-20
Bug fix for configure setup for automake v1.16+
2020-01-18
General SLHA parameter files for UFO models supported
2020-01-08
Bug fix: correctly register RECOLA processes with flavor sums
2019-12-19
Support for UFO customized propagators
O'Mega unit tests for fermion-number violating interactions
2019-12-10
For distribution building: check for graphviz/dot
version 2.40 or newer
2019-11-21
Bug fix: alternate setups now work correctly
Infrastructure for accessing alpha_QED event-by-event
Guard against tiny numbers that break ASCII event output
Enable inverse hyperbolic functions as SINDARIN observables
Remove old compiler bug workarounds
2019-11-20
Allow quoted -e argument, implemented -f option
2019-11-19
Bug fix: resonance histories now work also with UFO models
Fix in numerical precision of ASCII VAMP2 grids
2019-11-06
Add squared matrix elements to the LCIO event header
2019-11-05
Do not include RNG state in MD5 sum for CIRCE1/2
2019-11-04
Full CIRCE2 ILC 250 and 500 GeV beam spectra added
Minor update on LCIO event header information
2019-10-30
NLO QCD for final states completed
When using Openloops, v2.1.1+ mandatory
2019-10-25
Binary grid files for VAMP2 integrator
##################################################################
2019-10-24
RELEASE: version 2.8.2
2019-10-20
Bug fix for HepMC linker flags
2019-10-19
Support for spin-2 particles from UFO files
2019-09-27
LCIO event format allows rescan and alternate weights
2019-09-24
Compatibility fix for OCaml v4.08.0+
##################################################################
2019-09-21
RELEASE: version 2.8.1
2019-09-19
Carriage return characters in UFO models can be parsed
Mathematica symbols in UFO models possible
Unused/undefined parameters in UFO models handled
2019-09-13
New extended NLO test suite for ee and pp processes
2019-09-09
Photon isolation (separation of perturbative and fragmentation
part a la Frixione)
2019-09-05
Major progress on NLO QCD for hadron collisions:
- correctly assign flavor structures for alpha regions
- fix crossing of particles for initial state splittings
- correct assignment for PDF factors for real subtractions
- fix kinematics for collinear splittings
- bug fix for integrated virtual subtraction terms
2019-09-03
b and c jet selection in cuts and analysis
2019-08-27
Support for Intel MPI
2019-08-20
Complete (preliminary) HepMC3 support (incl.
backwards HepMC2 write/read mode)
2019-08-08
Bug fix: handle carriage returns in UFO files (non-Unix OS)
##################################################################
2019-08-07
RELEASE: version 2.8.0
2019-07-31
Complete WHIZARD UFO interface:
- general Lorentz structures
- matrix element support for general color factors
- missing features: Majorana fermions and SLHA
2019-07-20
Make WHIZARD compatible with OCaml 4.08.0+
2019-07-19
Fix version testing for LHAPDF 6.2.3 and newer
Minimal required OCaml version is now 4.02.3.
2019-04-18
Correctly generate ordered FKS tuples for alpha regions
from all possible underlying Born processes
2019-04-08
Extended O'Mega/Recola matrix element test suite
2019-03-29
Correct identical particle symmetry factors for FKS subtraction
2019-03-28
Correct assertion of spin-correlated matrix
elements for hadron collisions
2019-03-27
Bug fix for cut-off parameter delta_i for
collinear plus/minus regions
##################################################################
2019-03-27
RELEASE: version 2.7.1
2019-02-19
Further infrastructure for HepMC3 interface (v3.01.00)
2019-02-07
Explicit configure option for using debugging options
Bug fix for performance by removing unnecessary debug operations
2019-01-29
Bug fix for DGLAP remnants with cut-off parameter delta_i
2019-01-24
Radiative decay neu2 -> neu1 A added to MSSM_Hgg model
##################################################################
2019-01-21
RELEASE: version 2.7.0
2018-12-18
Support RECOLA for integrated und unintegrated subtractions
2018-12-11
FCNC top-up sector in model SM_top_anom
2018-12-05
Use libtirpc instead of SunRPC on Arch Linux etc.
2018-11-30
Display rescaling factor for weighted event samples with cuts
2018-11-29
Reintroduce check against different masses in flavor sums
Bug fix for wrong couplings in the Littlest Higgs model(s)
2018-11-22
Bug fix for rescanning events with beam structure
2018-11-09
Major refactoring of internal process data
2018-11-02
PYTHIA8 interface
2018-10-29
Flat phase space parametrization with RAMBO (on diet) implemented
2018-10-17
Revise extended test suite
2018-09-27
Process container for RECOLA processes
2018-09-15
Fixes by M. Berggren for PYTHIA6 interface
2018-09-14
First fixes after HepForge modernization
##################################################################
2018-08-23
RELEASE: version 2.6.4
2018-08-09
Infrastructure to check colored subevents
2018-07-10
Infrastructure for running WHIZARD in batch mode
2018-07-04
MPI available from distribution tarball
2018-06-03
Support Intel Fortran Compiler under MAC OS X
2018-05-07
FKS slicing parameter delta_i (initial state) implementend
2018-05-03
Refactor structure function assignment for NLO
2018-05-02
FKS slicing parameter xi_cut, delta_0 implemented
2018-04-20
Workspace subdirectory for process integration (grid/phs files)
Packing/unpacking of files at job end/start
Exporting integration results from scan loops
2018-04-13
Extended QCD NLO test suite
2018-04-09
Bug fix for Higgs Singlet Extension model
2018-04-06
Workspace subdirectory for process generation and compilation
--job-id option for creating job-specific names
2018-03-20
Bug fix for color flow matching in hadron collisions
with identical initial state quarks
2018-03-08
Structure functions quantum numbers correctly assigned for NLO
2018-02-24
Configure setup includes 'pgfortran' and 'flang'
2018-02-21
Include spin-correlated matrix elements in interactions
2018-02-15
Separate module for QED ISR structure functions
##################################################################
2018-02-10
RELEASE: version 2.6.3
2018-02-08
Improvements in memory management for PS generation
2018-01-31
Partial refactoring: quantum number assigment NLO
Initial-state QCD splittings for hadron collisions
2018-01-25
Bug fix for weighted events with VAMP2
2018-01-17
Generalized interface for Recola versions 1.3+ and 2.1+
2018-01-15
Channel equivalences also for VAMP2 integrator
2018-01-12
Fix for OCaml compiler 4.06 (and newer)
2017-12-19
RECOLA matrix elements with flavor sums can be integrated
2017-12-18
Bug fix for segmentation fault in empty resonance histories
2017-12-16
Fixing a bug in PYTHIA6 PYHEPC routine by omitting CMShowers
from transferral between PYTHIA and WHIZARD event records
2017-12-15
Event index for multiple processes in event file correct
##################################################################
2017-12-13
RELEASE: version 2.6.2
2017-12-07
User can set offset in event numbers
2017-11-29
Possibility to have more than one RECOLA process in one file
2017-11-23
Transversal/mixed (and unitarized) dim-8 operators
2017-11-16
epa_q_max replaces epa_e_max (trivial factor 2)
2017-11-15
O'Mega matrix element compilation silent now
2017-11-14
Complete expanded P-wave form factor for top threshold
2017-11-10
Incoming particles can be accessed in SINDARIN
2017-11-08
Improved handling of resonance insertion, additional parameters
2017-11-04
Added Higgs-electron coupling (SM_Higgs)
##################################################################
2017-11-03
RELEASE: version 2.6.1
2017-10-20
More than 5 NLO components possible at same time
2017-10-19
Gaussian cutoff for shower resonance matching
2017-10-12
Alternative (more efficient) method to generate
phase space file
2017-10-11
Bug fix for shower resonance histories for processes
with multiple components
2017-09-25
Bug fix for process libraries in shower resonance histories
2017-09-21
Correctly generate pT distribution for EPA remnants
2017-09-20
Set branching ratios for unstable particles also by hand
2017-09-14
Correctly generate pT distribution for ISR photons
##################################################################
2017-09-08
RELEASE: version 2.6.0
2017-09-05
Bug fix for initial state NLO QCD flavor structures
Real and virtual NLO QCD hadron collider processes
work with internal interactions
2017-09-04
Fully validated MPI integration and event generation
2017-09-01
Resonance histories for shower: full support
Bug fix in O'Mega model constraints
O'Mega allows to output a parsable form of the DAG
2017-08-24
Resonance histories in events for transferral
to parton shower (e.g. in ee -> jjjj)
2017-08-01
Alpha version of HepMC v3 interface
(not yet really functional)
2017-07-31
Beta version for RECOLA OLP support
2017-07-06
Radiation generator fix for LHC processes
2017-06-30
Fix bug for NLO with structure
functions and/or polarization
2017-06-23
Collinear limit for QED corrections works
2017-06-17
POWHEG grids generated already during integration
2017-06-12
Soft limit for QED corrections works
2017-05-16
Beta version of full MPI parallelization (VAMP2)
Check consistency of POWHEG grid files
Logfile config-summary.log for configure summary
2017-05-12
Allow polarization in top threshold
2017-05-09
Minimal demand automake 1.12.2
Silent rules for make procedures
2017-05-07
Major fix for POWHEG damping
Correctly initialize FKS ISR phasespace
##################################################################
2017-05-06
RELEASE: version 2.5.0
2017-05-05
Full UFO support (SM-like models)
Fixed-beam ISR FKS phase space
2017-04-26
QED splittings in radiation generator
2017-04-10
Retire deprecated O'Mega vertex cache files
##################################################################
2017-03-24
RELEASE: version 2.4.1
2017-03-16
Distinguish resonance charge in phase space channels
Keep track of resonance histories in phase space
Complex mass scheme default for OpenLoops amplitudes
2017-03-13
Fix helicities for polarized OpenLoops calculations
2017-03-09
Possibility to advance RNG state in rng_stream
2017-03-04
General setup for partitioning real emission
phase space
2017-03-06
Bug fix on rescan command for converting event files
2017-02-27
Alternative multi-channel VEGAS implementation
VAMP2: serial backbone for MPI setup
Smoothstep top threshold matching
2017-02-25
Single-beam structure function with
s-channel mapping supported
Safeguard against invalid process libraries
2017-02-16
Radiation generator for photon emission
2017-02-10
Fixes for NLO QCD processes (color correlations)
2017-01-16
LCIO variable takes precedence over LCIO_DIR
2017-01-13
Alternative random number generator
rng_stream (cf. L'Ecuyer et al.)
2017-01-01
Fix for multi-flavor BLHA tree
matrix elements
2016-12-31
Grid path option for VAMP grids
2016-12-28
Alpha version of Recola OLP support
2016-12-27
Dalitz plots for FKS phase space
2016-12-14
NLO multi-flavor events possible
2016-12-09
LCIO event header information added
2016-12-02
Alpha version of RECOLA interface
Bug fix for generator status in LCIO
##################################################################
2016-11-28
RELEASE: version 2.4.0
2016-11-24
Bug fix for OpenLoops interface: EW scheme
is set by WHIZARD
Bug fixes for top threshold implementation
2016-11-11
Refactoring of dispatching
2016-10-18
Bug fix for LCIO output
2016-10-10
First implementation for collinear soft terms
2016-10-06
First full WHIZARD models from UFO files
2016-10-05
WHIZARD does not support legacy gcc 4.7.4 any longer
2016-09-30
Major refactoring of process core and NLO components
2016-09-23
WHIZARD homogeneous entity: discarding subconfigures
for CIRCE1/2, O'Mega, VAMP subpackages; these are
reconstructable by script projectors
2016-09-06
Introduce main configure summary
2016-08-26
Fix memory leak in event generation
##################################################################
2016-08-25
RELEASE: version 2.3.1
2016-08-19
Bug fix for EW-scheme dependence of gluino propagators
2016-08-01
Beta version of complex mass scheme support
2016-07-26
Fix bug in POWHEG damping for the matching
##################################################################
2016-07-21
RELEASE: version 2.3.0
2016-07-20
UFO file support (alpha version) in O'Mega
2016-07-13
New (more) stable of WHIZARD GUI
Support for EW schemes for OpenLoops
Factorized NLO top decays for threshold model
2016-06-15
Passing factorization scale to PYTHIA6
Adding charge and neutral observables
2016-06-14
Correcting angular distribution/tweaked kinematics in
non-collinear structure functions splittings
2016-05-10
Include (Fortran) TAUOLA/PHOTOS for tau decays via PYTHIA6
(backwards validation of LC CDR/TDR samples)
2016-04-27
Within OpenLoops virtuals: support for Collier library
2016-04-25
O'Mega vertex tables only loaded at first usage
2016-04-21
New CJ15 PDF parameterizations added
2016-04-21
Support for hadron collisions at NLO QCD
2016-04-05
Support for different (parameter) schemes in model files
2016-03-31
Correct transferral of lifetime/vertex from PYTHIA/TAUOLA
into the event record
2016-03-21
New internal implementation of polarization
via Bloch vectors, remove pointer constructions
2016-03-13
Extension of cascade syntax for processes:
exclude propagators/vertices etc. possible
2016-02-24
Full support for OpenLoops QCD NLO matrix
elements, inclusion in test suite
2016-02-12
Substantial progress on QCD NLO support
2016-02-02
Automated resonance mapping for FKS subtraction
2015-12-17
New BSM model WZW for diphoton resonances
##################################################################
2015-11-22
RELEASE: version 2.2.8
2015-11-21
Bug fix for fixed-order NLO events
2015-11-20
Anomalous FCNC top-charm vertices
2015-11-19
StdHEP output via HEPEVT/HEPEV4 supported
2015-11-18
Full set of electroweak dim-6 operators included
2015-10-22
Polarized one-loop amplitudes supported
2015-10-21
Fixes for event formats for showered events
2015-10-14
Callback mechanism for event output
2015-09-22
Bypass matrix elements in pure event sample rescans
StdHep frozen final version v5.06.01 included internally
2015-09-21
configure option --with-precision to
demand 64bit, 80bit, or 128bit Fortran
and bind C precision types
2015-09-07
More extensive tests of NLO
infrastructure and POWHEG matching
2015-09-01
NLO decay infrastructure
User-defined squared matrix elements
Inclusive FastJet algorithm plugin
Numerical improvement for small boosts
##################################################################
2015-08-11
RELEASE: version 2.2.7
2015-08-10
Infrastructure for damped POWHEG
Massive emitters in POWHEG
Born matrix elements via BLHA
GoSam filters via SINDARIN
Minor running coupling bug fixes
Fixed-order NLO events
2015-08-06
CT14 PDFs included (LO, NLO, NNLL)
2015-07-07
Revalidation of ILC WHIZARD-PYTHIA event chain
Extended test suite for showered events
Alpha version of massive FSR for POWHEG
2015-06-09
Fix memory leak in interaction for long cascades
Catch mismatch between beam definition and CIRCE2 spectrum
2015-06-08
Automated POWHEG matching: beta version
Infrastructure for GKS matching
Alpha version of fixed-order NLO events
CIRCE2 polarization averaged spectra with
explicitly polarized beams
2015-05-12
Abstract matching type: OO structure for matching/merging
2015-05-07
Bug fix in event record WHIZARD-PYTHIA6 transferral
Gaussian beam spectra for lepton colliders
##################################################################
2015-05-02
RELEASE: version 2.2.6
2015-05-01
Models for (unitarized) tensor resonances in VBS
2015-04-28
Bug fix in channel weights for event generation.
2015-04-18
Improved event record transfer WHIZARD/PYTHIA6
2015-03-19
POWHEG matching: alpha version
##################################################################
2015-02-27
RELEASE: version 2.2.5
2015-02-26
Abstract types for quantum numbers
2015-02-25
Read-in of StdHEP events, self-tests
2015-02-22
Bug fix for mother-daughter relations in
showered/hadronized events
2015-02-20
Projection on polarization in intermediate states
2015-02-13
Correct treatment of beam remnants in
event formats (also LC remnants)
##################################################################
2015-02-06
RELEASE: version 2.2.4
2015-02-06
Bug fix in event output
2015-02-05
LCIO event format supported
2015-01-30
Including state matrices in WHIZARD's internal IO
Versioning for WHIZARD's internal IO
Libtool update from 2.4.3 to 2.4.5
LCIO event output (beta version)
2015-01-27
Progress on NLO integration
Fixing a bug for multiple processes in a single
event file when using beam event files
2015-01-19
Bug fix for spin correlations evaluated in the rest
frame of the mother particle
2015-01-17
Regression fix for statically linked processes
from SARAH and FeynRules
2015-01-10
NLO: massive FKS emitters supported (experimental)
2015-01-06
MMHT2014 PDF sets included
2015-01-05
Handling mass degeneracies in auto_decays
2014-12-19
Fixing bug in rescan of event files
##################################################################
2014-11-30
RELEASE: version 2.2.3
2014-11-29
Beta version of LO continuum/NLL-threshold
matched top threshold model for e+e- physics
2014-11-28
More internal refactoring: disentanglement of module
dependencies
2014-11-21
OVM: O'Mega Virtual Machine, bytecode instructions
instead of compiled Fortran code
2014-11-01
Higgs Singlet extension model included
2014-10-18
Internal restructuring of code; half-way
WHIZARD main code file disassembled
2014-07-09
Alpha version of NLO infrastructure
##################################################################
2014-07-06
RELEASE: version 2.2.2
2014-07-05
CIRCE2: correlated LC beam spectra and
GuineaPig Interface to LC machine parameters
2014-07-01
Reading LHEF for decayed/factorized/showered/
hadronized events
2014-06-25
Configure support for GoSAM/Ninja/Form/QGraf
2014-06-22
LHAPDF6 interface
2014-06-18
Module for automatic generation of
radiation and loop infrastructure code
2014-06-11
Improved internal directory structure
##################################################################
2014-06-03
RELEASE: version 2.2.1
2014-05-30
Extensions of internal PDG arrays
2014-05-26
FastJet interface
2014-05-24
CJ12 PDFs included
2014-05-20
Regression fix for external models (via SARAH
or FeynRules)
##################################################################
2014-05-18
RELEASE: version 2.2.0
2014-04-11
Multiple components: inclusive process definitions,
syntax: process A + B + ...
2014-03-13
Improved PS mappings for e+e- ISR
ILC TDR and CLIC spectra included in CIRCE1
2014-02-23
New models: AltH w\ Higgs for exclusion purposes,
SM_rx for Dim 6-/Dim-8 operators, SSC for
general strong interactions (w/ Higgs), and
NoH_rx (w\ Higgs)
2014-02-14
Improved s-channel mapping, new on-shell
production mapping (e.g. Drell-Yan)
2014-02-03
PRE-RELEASE: version 2.2.0_beta
2014-01-26
O'Mega: Feynman diagram generation possible (again)
2013-12-16
HOPPET interface for b parton matching
2013-11-15
PRE-RELEASE: version 2.2.0_alpha-4
2013-10-27
LHEF standards 1.0/2.0/3.0 implemented
2013-10-15
PRE-RELEASE: version 2.2.0_alpha-3
2013-10-02
PRE-RELEASE: version 2.2.0_alpha-2
2013-09-25
PRE-RELEASE: version 2.2.0_alpha-1
2013-09-12
PRE-RELEASE: version 2.2.0_alpha
2013-09-03
General 2HDM implemented
2013-08-18
Rescanning/recalculating events
2013-06-07
Reconstruction of complete event
from 4-momenta possible
2013-05-06
Process library stacks
2013-05-02
Process stacks
2013-04-29
Single-particle phase space module
2013-04-26
Abstract interface for random
number generator
2013-04-24
More object-orientation on modules
Midpoint-rule integrator
2013-04-05
Object-oriented integration and
event generation
2013-03-12
Processes recasted object-oriented:
MEs, scales, structure functions
First infrastructure for general Lorentz
structures
2013-01-17
Object-orientated reworking of library and
process core, more variable internal structure,
unit tests
2012-12-14
Update Pythia version to 6.4.27
2012-12-04
Fix the phase in HAZ vertices
2012-11-21
First O'Mega unit tests, some infrastructure
2012-11-13
Bug fix in anom. HVV Lorentz structures
##################################################################
2012-09-18
RELEASE: version 2.1.1
2012-09-11
Model MSSM_Hgg with Hgg and HAA vertices
2012-09-10
First version of implementation of multiple
interactions in WHIZARD
2012-09-05
Infrastructure for internal CKKW matching
2012-09-02
C, C++, Python API
2012-07-19
Fixing particle numbering in HepMC format
##################################################################
2012-06-15
RELEASE: version 2.1.0
2012-06-14
Analytical and kT-ordered shower officially
released
PYTHIA interface officially released
2012-05-09
Intrisince PDFs can be used for showering
2012-05-04
Anomalous Higgs couplings a la hep-ph/9902321
##################################################################
2012-03-19
RELEASE: version 2.0.7
2012-03-15
Run IDs are available now
More event variables in analysis
Modified raw event format (compatibility mode exists)
2012-03-12
Bug fix in decay-integration order
MLM matching steered completely internally now
2012-03-09
Special phase space mapping for narrow resonances
decaying to 4-particle final states with far off-shell
intermediate states
Running alphas from PDF collaborations with
builtin PDFs
2012-02-16
Bug fix in cascades decay infrastructure
2012-02-04
WHIZARD documentation compatible with TeXLive 2011
2012-02-01
Bug fix in FeynRules interface with --prefix flag
2012-01-29
Bug fix with name clash of O'Mega variable names
2012-01-27
Update internal PYTHIA to version 6.4.26
Bug fix in LHEF output
2012-01-21
Catching stricter automake 1.11.2 rules
2011-12-23
Bug fix in decay cascade setup
2011-12-20
Bug fix in helicity selection rules
2011-12-16
Accuracy goal reimplemented
2011-12-14
WHIZARD compatible with TeXLive 2011
2011-12-09
Option --user-target added
##################################################################
2011-12-07
RELEASE: version 2.0.6
2011-12-07
Bug fixes in SM_top_anom
Added missing entries to HepMC format
2011-12-06
Allow to pass options to O'Mega
Bug fix for HEPEVT block for showered/hadronized events
2011-12-01
Reenabled user plug-in for external code for
cuts, structure functions, routines etc.
2011-11-29
Changed model SM_Higgs for Higgs phenomenology
2011-11-25
Supporting a Y, (B-L) Z' model
2011-11-23
Make WHIZARD compatible for MAC OS X Lion/XCode 4
2011-09-25
WHIZARD paper published: Eur.Phys.J. C71 (2011) 1742
2011-08-16
Model SM_QCD: QCD with one EW insertion
2011-07-19
Explicit output channel for dvips avoids printing
2011-07-10
Test suite for WHIZARD unit tests
2011-07-01
Commands for matrix element tests
More OpenMP parallelization of kinematics
Added unit tests
2011-06-23
Conversion of CIRCE2 from F77 to F90, major
clean-up
2011-06-14
Conversion of CIRCE1 from F77 to F90
2011-06-10
OpenMP parallelization of channel kinematics
(by Matthias Trudewind)
2011-05-31
RELEASE: version 1.97
2011-05-24
Minor bug fixes: update grids and elsif statement.
##################################################################
2011-05-10
RELEASE: version 2.0.5
2011-05-09
Fixed bug in final state flavor sums
Minor improvements on phase-space setup
2011-05-05
Minor bug fixes
2011-04-15
WHIZARD as a precompiled 64-bit binary available
2011-04-06
Wall clock instead of cpu time for time estimates
2011-04-05
Major improvement on the phase space setup
2011-04-02
OpenMP parallelization for helicity loop in O'Mega
matrix elements
2011-03-31
Tools for relocating WHIZARD and use in batch
environments
2011-03-29
Completely static builds possible, profiling options
2011-03-28
Visualization of integration history
2011-03-27
Fixed broken K-matrix implementation
2011-03-23
Including the GAMELAN manual in the distribution
2011-01-26
WHIZARD analysis can handle hadronized event files
2011-01-17
MSTW2008 and CT10 PDF sets included
2010-12-23
Inclusion of NMSSM with Hgg couplings
2010-12-21
Advanced options for integration passes
2010-11-16
WHIZARD supports CTEQ6 and possibly other PDFs
directly; data files included in the distribution
##################################################################
2010-10-26
RELEASE: version 2.0.4
2010-10-06
Bug fix in MSSM implementation
2010-10-01
Update to libtool 2.4
2010-09-29
Support for anomalous top couplings (form factors etc.)
Bug fix for running gauge Yukawa SUSY couplings
2010-09-28
RELEASE: version 1.96
2010-09-21
Beam remnants and pT spectra for lepton collider re-enabled
Restructuring subevt class
2010-09-16
Shower and matching are disabled by default
PYTHIA as a conditional on these two options
2010-09-14
Possibility to read in beam spectra re-enabled (e.g. Guinea
Pig)
2010-09-13
Energy scan as (pseudo-) structure functions re-implemented
2010-09-10
CIRCE2 included again in WHIZARD 2 and validated
2010-09-02
Re-implementation of asymmetric beam energies and collision
angles, e-p collisions work, inclusion of a HERA DIS test
case
##################################################################
2010-10-18
RELEASE: version 2.0.3
2010-08-08
Bug in CP-violating anomalous triple TGCs fixed
2010-08-06
Solving backwards compatibility problem with O'Caml 3.12.0
2010-07-12
Conserved quantum numbers speed up O'Mega code generation
2010-07-07
Attaching full ISR/FSR parton shower and MPI/ISR
module
Added SM model containing Hgg, HAA, HAZ vertices
2010-07-02
Matching output available as LHEF and STDHEP
2010-06-30
Various bug fixes, missing files, typos
2010-06-26
CIRCE1 completely re-enabled
Chaining structure functions supported
2010-06-25
Partial support for conserved quantum numbers in
O'Mega
2010-06-21
Major upgrade of the graphics package: error bars,
smarter SINDARIN steering, documentation, and all that...
2010-06-17
MLM matching with PYTHIA shower included
2010-06-16
Added full CIRCE1 and CIRCE2 versions including
full documentation and miscellanea to the trunk
2010-06-12
User file management supported, improved variable
and command structure
2010-05-24
Improved handling of variables in local command lists
2010-05-20
PYTHIA interface re-enabled
2010-05-19
ASCII file formats for interfacing ROOT and gnuplot in
data analysis
##################################################################
2010-05-18
RELEASE: version 2.0.2
2010-05-14
Reimplementation of visualization of phase space
channels
Minor bug fixes
2010-05-12
Improved phase space - elimination of redundancies
2010-05-08
Interface for polarization completed: polarized beams etc.
2010-05-06
Full quantum numbers appear in process log
Integration results are usable as user variables
Communication with external programs
2010-05-05
Split module commands into commands, integration,
simulation modules
2010-05-04
FSR+ISR for the first time connected to the WHIZARD 2 core
##################################################################
2010-04-25
RELEASE: version 2.0.1
2010-04-23
Automatic compile and integrate if simulate is called
Minor bug fixes in O'Mega
2010-04-21
Checkpointing for event generation
Flush statements to use WHIZARD inside a pipe
2010-04-20
Reimplementation of signal handling in WGIZARD 2.0
2010-04-19
VAMP is now a separately configurable and installable unit of
WHIZARD, included VAMP self-checks
Support again compilation in quadruple precision
2010-04-06
Allow for logarithmic plots in GAMELAN, reimplement the
possibility to set the number of bins
2010-04-15
Improvement on time estimates for event generation
##################################################################
2010-04-12
RELEASE: version 2.0.0
2010-04-09
Per default, the code for the amplitudes is subdivided to allow
faster compiler optimization
More advanced and unified and straightforward command language
syntax
Final bug fixes
2010-04-07
Improvement on SINDARIN syntax; printf, sprintf function
thorugh a C interface
2010-04-05
Colorizing DAGs instead of model vertices: speed boost
in colored code generation
2010-03-31
Generalized options for normalization of weighted and
unweighted events
Grid and weight histories added again to log files
Weights can be used in analyses
2010-03-28
Cascade decays completely implemented including color and
spin correlations
2010-03-07
Added new WHIZARD header with logo
2010-03-05
Removed conflict in O'Mega amplitudes between flavour sums
and cascades
StdHEP interface re-implemented
2010-03-03
RELEASE: version 2.0.0rc3
Several bug fixes for preventing abuse in input files
OpenMP support for amplitudes
Reimplementation of WHIZARD 1 HEPEVT ASCII event formats
FeynRules interface successfully passed MSSM test
2010-02-26
Eliminating ghost gluons from multi-gluon amplitudes
2010-02-25
RELEASE: version 1.95
HEPEVT format from WHIZARD 1 re-implemented in WHIZARD 2
2010-02-23
Running alpha_s implemented in the FeynRules interface
2010-02-19
MSSM (semi-) automatized self-tests finalized
2010-02-17
RELEASE: version 1.94
2010-02-16
Closed memory corruption in WHIZARD 1
Fixed problems of old MadGraph and CompHep drivers
with modern compilers
Uncolored vertex selection rules for colored amplitudes in
O'Mega
2010-02-15
Infrastructure for color correlation computation in O'Mega
finished
Forbidden processes are warned about, but treated as non-fatal
2010-02-14
Color correlation computation in O'Mega finalized
2010-02-10
Improving phase space mappings for identical particles in
initial and final states
Introduction of more extended multi-line error message
2010-02-08
First O'Caml code for computation of color correlations in
O'Mega
2010-02-07
First MLM matching with e+ e- -> jets
##################################################################
2010-02-06
RELEASE: version 2.0.0rc2
2010-02-05
Reconsidered the Makefile structure and more extended tests
Catch a crash between WHIZARD and O'Mega for forbidden processes
Tensor products of arbitrary color structures in jet definitions
2010-02-04
Color correlation computation in O'Mega finalized
##################################################################
2010-02-03
RELEASE: version 2.0.0rc1
##################################################################
2010-01-31
Reimplemented numerical helicity selection rules
Phase space functionality of version 1 restored and improved
2009-12-05
NMSSM validated with FeynRules in WHIZARD 1 (Felix Braam)
2009-12-04
RELEASE: version 2.0.0alpha
##################################################################
2009-04-16
RELEASE: version 1.93
2009-04-15
Clean-up of Makefiles and configure scripts
Reconfiguration of BSM model implementation
extended supersymmetric models
2008-12-23
New model NMSSM (Felix Braam)
SLHA2 added
Bug in LHAPDF interface fixed
2008-08-16
Bug fixed in K matrix implementation
Gravitino option in the MSSM added
2008-03-20
Improved color and flavor sums
##################################################################
2008-03-12
RELEASE: version 1.92
LHEF (Les Houches Event File) format added
Fortran 2003 command-line interface (if supported by the compiler)
Automated interface to colored models
More bug fixes and workarounds for compiler compatibility
##################################################################
2008-03-06
RELEASE: version 1.91
New model K-matrix (resonances and anom. couplings in WW scattering)
EWA spectrum
Energy-scan pseudo spectrum
Preliminary parton shower module (only from final-state quarks)
Cleanup and improvements of configure process
Improvements for O'Mega parameter files
Quadruple precision works again
More plotting options: lines, symbols, errors
Documentation with PDF bookmarks enabled
Various bug fixes
2007-11-29
New model UED
##################################################################
2007-11-23
RELEASE: version 1.90
O'Mega now part of the WHIZARD tree
Madgraph/CompHEP disabled by default (but still usable)
Support for LHAPDF (preliminary)
Added new models: SMZprime, SM_km, Template
Improved compiler recognition and compatibility
Minor bug fixes
##################################################################
2006-06-15
RELEASE: version 1.51
Support for anomaly-type Higgs couplings (to gluon and photon/Z)
Support for spin 3/2 and spin 2
New models: Little Higgs (4 versions), toy models for extra dimensions
and gravitinos
Fixes to the whizard.nw source documentation to run through LaTeX
Intel 9.0 bug workaround (deallocation of some arrays)
2006-05-15
O'Mega RELEASE: version 0.11
merged JRR's O'Mega extensions
##################################################################
2006-02-07
RELEASE: version 1.50
To avoid confusion: Mention outdated manual example in BUGS file
O'Mega becomes part of the WHIZARD generator
2006-02-02 [bug fix update]
Bug fix: spurious error when writing event files for weighted events
Bug fix: 'r' option for omega produced garbage for some particle names
Workaround for ifort90 bug (crash when compiling whizard_event)
Workaround for ifort90 bug (crash when compiling hepevt_common)
2006-01-27
Added process definition files for MSSM 2->2 processes
Included beam recoil for EPA (T.Barklow)
Updated STDHEP byte counts (for STDHEP 5.04.02)
Fixed STDHEP compatibility (avoid linking of incomplete .so libs)
Fixed issue with comphep requiring Xlibs on Opteron
Fixed issue with ifort 8.x on Opteron (compiling 'signal' interface)
Fixed color-flow code: was broken for omega with option 'c' and 'w'
Workaround hacks for g95 compatibility
2005-11-07
O'Mega RELEASE: version 0.10
O'Mega, merged JRR's and WK's color hack for WHiZard
O'Mega, EXPERIMENTAL: cache fusion tables (required for colors
a la JRR/WK)
O'Mega, make JRR's MSSM official
##################################################################
2005-10-25
RELEASE: version 1.43
Minor fixes in MSSM couplings (Higgs/3rd gen squarks).
This should be final, since the MSSM results agree now completely
with Madgraph and Sherpa
User-defined lower and upper limits for split event file count
Allow for counters (events, bytes) exceeding $2^{31}$
Revised checksum treatment and implementation (now MD5)
Bug fix: missing process energy scale in raw event file
##################################################################
2005-09-30
RELEASE: version 1.42
Graphical display of integration history ('make history')
Allow for switching off signals even if supported (configure option)
2005-09-29
Revised phase space generation code, in particular for flavor sums
Negative cut and histogram codes use initial beams instead of
initial parton momenta. This allows for computing, e.g., E_miss
Support constant-width and zero-width options for O'Mega
Width options now denoted by w:X (X=f,c,z). f option obsolescent
Bug fix: colorized code: flipped indices could screw up result
Bug fix: O'Mega with 'c' and 'w:f' option together (still some problem)
Bug fix: dvips on systems where dvips defaults to lpr
Bug fix: integer overflow if too many events are requested
2005-07-29
Allow for 2 -> 1 processes (if structure functions are on)
2005-07-26
Fixed and expanded the 'test' matrix element:
Unit matrix element with option 'u' / default: normalized phase space
##################################################################
2005-07-15
RELEASE: version 1.41
Bug fix: no result for particle decay processes with width=0
Bug fix: line breaks in O'Mega files with color decomposition
2005-06-02
New self-tests (make test-QED / test-QCD / test-SM)
check lists of 2->2 processes
Bug fix: HELAS calling convention for wwwwxx and jwwwxx (4W-Vertex)
2005-05-25
Revised Makefile structure
Eliminated obsolete references to ISAJET/SUSY (superseded by SLHA)
2005-05-19
Support for color in O'Mega (using color flow decomposition)
New model QCD
Parameter file changes that correspond to replaced SM module in O'Mega
Bug fixes in MSSM (O'Mega) parameter file
2005-05-18
New event file formats, useful for LHC applications:
ATHENA and Les Houches Accord (external fragmentation)
Naive (i.e., leading 1/N) color factor now implemented both for
incoming and outgoing partons
2005-01-26
include missing HELAS files for bundle
pgf90 compatibility issues [note: still internal error in pgf90]
##################################################################
2004-12-13
RELEASE: version 1.40
compatibility fix: preprocessor marks in helas code now commented out
minor bug fix: format string in madgraph source
2004-12-03
support for arbitray beam energies and directions
allow for pT kick in structure functions
bug fix: rounding error could result in zero cross section
(compiler-dependent)
2004-10-07
simulate decay processes
list fraction (of total width/cross section) instead of efficiency
in process summary
new cut/analysis parameters AA, AAD, CTA: absolute polar angle
2004-10-04
Replaced Madgraph I by Madgraph II. Main improvement: model no
longer hardcoded
introduced parameter reset_seed_each_process (useful for debugging)
bug fix: color initialization for some processes was undefined
2004-09-21
don't compile unix_args module if it is not required
##################################################################
2004-09-20
RELEASE: version 1.30
g95 compatibility issues resolved
some (irrelevant) memory leaks closed
removed obsolete warning in circe1
manual update (essentially) finished
2004-08-03
O'Mega RELEASE: version 0.9
O'Mega, src/trie.mli, src/trie.ml: make interface compatible with
the O'Caml 3.08 library (remains compatible with older
versions). Implementation of unused functions still
incomplete.
2004-07-26
minor fixes and improvements in make process
2004-06-29
workarounds for new Intel compiler bugs ...
no rebuild of madgraph/comphep executables after 'make clean'
bug fix in phase space routine:
wrong energy for massive initial particles
bug fix in (new) model interface: name checks for antiparticles
pre-run checks for comphep improved
ww-strong model file extended
Model files particle name fixes, chep SM vertices included
2004-06-22
O'Mega RELEASE: version 0.8
O'Mega MSSM: sign of W+/W-/A and W+/W-/Z couplings
2004-05-05
Fixed bug in PDFLIB interface: p+pbar was initialized as p+p (ThO)
NAG compiler: set number of continuation lines to 200 as default
Extended format for cross section summary; appears now in whizard.out
Fixed 'bundle' feature
2004-04-28
Fixed compatibility with revised O'Mega SM_ac model
Fixed problem with x=0 or x=1 when calling PDFLIB (ThO)
Fixed bug in comphep module: Vtb was overlooked
##################################################################
2004-04-15
RELEASE: version 1.28
Fixed bug: Color factor was missing for O'Mega processes with
four quarks and more
Manual partially updated
2004-04-08
Support for grid files in binary format
New default value show_histories=F (reduce output file size)
Revised phase space switches: removed annihilation_lines,
removed s_channel_resonance, changed meaning of
extra_off_shell_lines, added show_deleted_channels
Bug fixed which lead to omission of some phase space channels
Color flow guessed only if requested by guess_color_flow
2004-03-10
New model interface: Only one model name specified in whizard.prc
All model-dependent files reside in conf/models (modellib removed)
2004-03-03
Support for input/output in SUSY Les Houches Accord format
Split event files if requested
Support for overall time limit
Support for CIRCE and CIRCE2 generator mode
Support for reading beam events from file
2004-02-05
Fixed compiler problems with Intel Fortran 7.1 and 8.0
Support for catching signals
##################################################################
2003-08-06
RELEASE: version 1.27
User-defined PDF libraries as an alternative to the standard PDFLIB
2003-07-23
Revised phase space module: improved mappings for massless particles,
equivalences of phase space channels are exploited
Improved mapping for PDF (hadron colliders)
Madgraph module: increased max number of color flows from 250 to 1000
##################################################################
2003-06-23
RELEASE: version 1.26
CIRCE2 support
Fixed problem with 'TC' integer kind [Intel compiler complained]
2003-05-28
Support for drawing histograms of grids
Bug fixes for MSSM definitions
##################################################################
2003-05-22
RELEASE: version 1.25
Experimental MSSM support with ISAJET interface
Improved capabilities of generating/analyzing weighted events
Optional drawing phase space diagrams using FeynMF
##################################################################
2003-01-31
RELEASE: version 1.24
A few more fixes and workarounds (Intel and Lahey compiler)
2003-01-15
Fixes and workarounds needed for WHIZARD to run with Intel compiler
Command-line option interface for the Lahey compiler
Bug fix: problem with reading whizard.phs
##################################################################
2002-12-10
RELEASE: version 1.23
Command-line options (on some systems)
Allow for initial particles in the event record, ordered:
[beams, initials] - [remnants] - outgoing partons
Support for PYTHIA 6.2: Les Houches external process interface
String pythia_parameters can be up to 1000 characters long
Select color flow states in (internal) analysis
Bug fix in color flow content of raw event files
Support for transversal polarization of fermion beams
Cut codes: PHI now for absolute azimuthal angle, DPHI for distance
'Test' matrix elements optionally respect polarization
User-defined code can be inserted for spectra, structure functions
and fragmentation
Time limits can be specified for adaptation and simulation
User-defined file names and file directory
Initial weights in input file no longer supported
Bug fix in MadGraph (wave function counter could overflow)
Bug fix: Gamelan (graphical analysis) was not built if noweb absent
##################################################################
2002-03-16
RELEASE: version 1.22
Allow for beam remnants in the event record
2002-03-01
Handling of aliases in whizard.prc fixed (aliases are whole tokens)
2002-02-28
Optimized phase space handling routines
(total execution time reduced by 20-60%, depending on process)
##################################################################
2002-02-26
RELEASE: version 1.21
Fixed ISR formula (ISR was underestimated in previous versions).
New version includes ISR in leading-log approximation up to
third order. Parameter ISR_sqrts renamed to ISR_scale.
##################################################################
2002-02-19
RELEASE: version 1.20
New process-generating method 'test' (dummy matrix element)
Compatibility with autoconf 2.50 and current O'Mega version
2002-02-05
Prevent integration channels from being dropped (optionally)
New internal mapping for structure functions improves performance
Old whizard.phx file deleted after recompiling (could cause trouble)
2002-01-24
Support for user-defined cuts and matrix element reweighting
STDHEP output now written by write_events_format=20 (was 3)
2002-01-16
Improved structure function handling; small changes in user interface:
new parameter structured_beams in &process_input
parameter fixed_energy in &beam_input removed
Support for multiple initial states
Eta-phi (cone) cut possible (hadron collider applications)
Fixed bug: Whizard library was not always recompiled when necessary
Fixed bug: Default cuts were insufficient in some cases
Fixed bug: Unusable phase space mappings generated in some cases
2001-12-06
Reorganized document source
2001-12-05
Preliminary CIRCE2 support (no functionality yet)
2001-11-27
Intel compiler support (does not yet work because of compiler bugs)
New cut and analysis mode cos-theta* and related
Fixed circular jetset_interface dependency warning
Some broadcast routines removed (parallel support disabled anyway)
Minor shifts in cleanup targets (Makefiles)
Modified library search, check for pdflib8*
2001-08-06
Fixed bug: I/O unit number could be undefined when reading phase space
Fixed bug: Unitialized variable could cause segfault when
event generation was disabled
Fixed bug: Undefined subroutine in CIRCE replacement module
Enabled feature: TGCs in O'Mega (not yet CompHEP!) matrix elements
(CompHEP model sm-GF #5, O'Mega model SM_ac)
Fixed portability issue: Makefile did rely on PWD environment variable
Fixed portability issue: PYTHIA library search ambiguity resolved
2001-08-01
Default whizard.prc and whizard.in depend on activated modules
Fixed bug: TEX=latex was not properly enabled when making plots
2001-07-20
Fixed output settings in PERL script calls
Cache enabled in various configure checks
2001-07-13
Support for multiple processes in a single WHIZARD run. The
integrations are kept separate, but the generated events are mixed
The whizard.evx format has changed (incompatible), including now
the color flow information for PYTHIA fragmentation
Output files are now process-specific, except for the event file
Phase space file whizard.phs (if present) is used only as input,
program-generated phase space is now in whizard.phx
2001-07-10
Bug fix: Undefined parameters in parameters_SM_ac.f90 removed
2001-07-04
Bug fix: Compiler options for the case OMEGA is disabled
Small inconsistencies in whizard.out format fixed
2001-07-01
Workaround for missing PDFLIB dummy routines in PYTHIA library
##################################################################
2001-06-30
RELEASE: version 1.13
Default path /cern/pro/lib in configure script
2001-06-20
New fragmentation option: Interface for PYTHIA with full color flow
information, beam remnants etc.
2001-06-18
Severe bug fixed in madgraph interface: 3-gluon coupling was missing
Enabled color flow information in madgraph
2001-06-11
VAMP interface module rewritten
Revised output format: Multiple VAMP iterations count as one WHIZARD
iteration in integration passes 1 and 3
Improved message and error handling
Bug fix in VAMP: handle exceptional cases in rebinning_weights
2001-05-31
new parameters for grid adaptation: accuracy_goal and efficiency_goal
##################################################################
2001-05-29
RELEASE: version 1.12
bug fixes (compilation problems): deleted/modified unused functions
2001-05-16
diagram selection improved and documented
2001-05-06
allow for disabling packages during configuration
2001-05-03
slight changes in whizard.out format; manual extended
##################################################################
2001-04-20
RELEASE: version 1.11
fixed some configuration and compilation problems (PDFLIB etc.)
2001-04-18
linked PDFLIB: support for quark/gluon structure functions
2001-04-05
parameter interface written by PERL script
SM_ac model file: fixed error in continuation line
2001-03-13
O'Mega, O'Caml 3.01: incompatible changes
O'Mega, src/trie.mli: add covariance annotation to T.t
This breaks O'Caml 3.00, but is required for O'Caml 3.01.
O'Mega, many instances: replace `sig include Module.T end' by
`Module.T', since the bug is fixed in O'Caml 3.01
2001-02-28
O'Mega, src/model.mli:
new field Model.vertices required for model functors, will
retire Model.fuse2, Model.fuse3, Model.fusen soon.
##################################################################
2001-03-27
RELEASE: version 1.10
reorganized the modules as libraries
linked PYTHIA: support for parton fragmentation
2000-12-14
fixed some configuration problems (if noweb etc. are absent)
##################################################################
2000-12-01
RELEASE of first public version: version 1.00beta
Index: trunk/src/beams/beams.nw
===================================================================
--- trunk/src/beams/beams.nw (revision 8842)
+++ trunk/src/beams/beams.nw (revision 8843)
@@ -1,28273 +1,28273 @@
%% -*- 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]]>>=
<<File header>>
module beam_structures
<<Use kinds>>
<<Use strings>>
use lorentz
use polarizations
<<Standard module head>>
<<Beam structures: public>>
<<Beam structures: types>>
<<Beam structures: interfaces>>
interface
<<Beam structures: sub interfaces>>
end interface
end module beam_structures
@ %def beam_structures
@
<<[[beam_structures_sub.f90]]>>=
<<File header>>
submodule (beam_structures) beam_structures_s
use io_units
use format_defs, only: FMT_19
use diagnostics
implicit none
contains
<<Beam structures: procedures>>
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.
<<Beam structures: types>>=
type :: beam_structure_entry_t
logical :: is_valid = .false.
type(string_t) :: name
contains
<<Beam structures: beam structure entry: TBP>>
end type beam_structure_entry_t
@ %def beam_structure_entry_t
@ Output.
<<Beam structures: beam structure entry: TBP>>=
procedure :: to_string => beam_structure_entry_to_string
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: types>>=
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.
<<Beam structures: public>>=
public :: beam_structure_t
<<Beam structures: types>>=
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
<<Beam structures: beam structure: TBP>>
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.
<<Beam structures: beam structure: TBP>>=
procedure :: final_sf => beam_structure_final_sf
<<Beam structures: sub interfaces>>=
module subroutine beam_structure_final_sf (object)
class(beam_structure_t), intent(inout) :: object
end subroutine beam_structure_final_sf
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: write => beam_structure_write
procedure :: to_string => beam_structure_to_string
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: init_sf => beam_structure_init_sf
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: set_sf => beam_structure_set_sf
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: interfaces>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: expand => beam_structure_expand
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: final_pol => beam_structure_final_pol
procedure :: init_pol => beam_structure_init_pol
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: has_polarized_beams => beam_structure_has_polarized_beams
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: set_smatrix => beam_structure_set_smatrix
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: init_smatrix => beam_structure_init_smatrix
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: set_sentry => beam_structure_set_sentry
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: set_pol_f => beam_structure_set_pol_f
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: final_mom => beam_structure_final_mom
<<Beam structures: sub interfaces>>=
module subroutine beam_structure_final_mom (beam_structure)
class(beam_structure_t), intent(inout) :: beam_structure
end subroutine beam_structure_final_mom
<<Beam structures: procedures>>=
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
<<Beam structures: beam structure: TBP>>=
procedure :: set_momentum => beam_structure_set_momentum
procedure :: set_theta => beam_structure_set_theta
procedure :: set_phi => beam_structure_set_phi
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: is_set => beam_structure_is_set
procedure :: get_n_beam => beam_structure_get_n_beam
procedure :: get_prt => beam_structure_get_prt
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: get_n_record => beam_structure_get_n_record
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: get_i_entry => beam_structure_get_i_entry
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: get_name => beam_structure_get_name
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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
@
<<Beam structures: beam structure: TBP>>=
procedure :: has_pdf => beam_structure_has_pdf
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.)
<<Beam structures: beam structure: TBP>>=
procedure :: contains => beam_structure_contains
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
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
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: get_momenta => beam_structure_get_momenta
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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.
<<Beam structures: beam structure: TBP>>=
procedure :: check_against_n_in => beam_structure_check_against_n_in
<<Beam structures: sub interfaces>>=
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
<<Beam structures: procedures>>=
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]]>>=
<<File header>>
module beam_structures_ut
use unit_tests
use beam_structures_uti
<<Standard module head>>
<<Beam structures: public test>>
contains
<<Beam structures: test driver>>
end module beam_structures_ut
@ %def beam_structures_ut
@
<<[[beam_structures_uti.f90]]>>=
<<File header>>
module beam_structures_uti
<<Use kinds>>
<<Use strings>>
use beam_structures
<<Standard module head>>
<<Beam structures: test declarations>>
contains
<<Beam structures: tests>>
<<Beam structures: test auxiliary>>
end module beam_structures_uti
@ %def beam_structures_ut
@ API: driver for the unit tests below.
<<Beam structures: public test>>=
public :: beam_structures_test
<<Beam structures: test driver>>=
subroutine beam_structures_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Beam structures: execute tests>>
end subroutine beam_structures_test
@ %def beam_structures_tests
@
\subsubsection{Empty structure}
<<Beam structures: execute tests>>=
call test (beam_structures_1, "beam_structures_1", &
"empty beam structure record", &
u, results)
<<Beam structures: test declarations>>=
public :: beam_structures_1
<<Beam structures: tests>>=
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}
<<Beam structures: execute tests>>=
call test (beam_structures_2, "beam_structures_2", &
"beam structure records", &
u, results)
<<Beam structures: test declarations>>=
public :: beam_structures_2
<<Beam structures: tests>>=
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:
<<Beam structures: test auxiliary>>=
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
@
<<Beam structures: execute tests>>=
call test (beam_structures_3, "beam_structures_3", &
"beam structure expansion", &
u, results)
<<Beam structures: test declarations>>=
public :: beam_structures_3
<<Beam structures: tests>>=
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.
<<Beam structures: execute tests>>=
call test (beam_structures_4, "beam_structures_4", &
"beam structure contents", &
u, results)
<<Beam structures: test declarations>>=
public :: beam_structures_4
<<Beam structures: tests>>=
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.
<<Beam structures: execute tests>>=
call test (beam_structures_5, "beam_structures_5", &
"polarization", &
u, results)
<<Beam structures: test declarations>>=
public :: beam_structures_5
<<Beam structures: tests>>=
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.
<<Beam structures: execute tests>>=
call test (beam_structures_6, "beam_structures_6", &
"momenta", &
u, results)
<<Beam structures: test declarations>>=
public :: beam_structures_6
<<Beam structures: tests>>=
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]]>>=
<<File header>>
module beams
<<Use kinds>>
<<Use strings>>
use lorentz
use model_data
use flavors
use quantum_numbers
use state_matrices
use interactions
use polarizations
use beam_structures
<<Standard module head>>
<<Beams: public>>
<<Beams: types>>
<<Beams: interfaces>>
interface
<<Beams: sub interfaces>>
end interface
end module beams
@ %def beams
@
<<[[beams_sub.f90]]>>=
<<File header>>
submodule (beams) beams_s
use io_units
use format_defs, only: FMT_19
use numeric_utils
use diagnostics
use md5
implicit none
contains
<<Beams: procedures>>
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.
<<Beams: public>>=
public :: beam_data_t
<<Beams: types>>=
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
<<Beams: beam data: TBP>>
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.
<<Beams: procedures>>=
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.
<<Beams: beam data: TBP>>=
procedure :: final => beam_data_final
<<Beams: sub interfaces>>=
module subroutine beam_data_final (beam_data)
class(beam_data_t), intent(inout) :: beam_data
end subroutine beam_data_final
<<Beams: procedures>>=
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.
<<Beams: beam data: TBP>>=
procedure :: write => beam_data_write
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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:
<<Beams: beam data: TBP>>=
procedure :: are_valid => beam_data_are_valid
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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.
<<Beams: beam data: TBP>>=
procedure :: check_scattering => beam_data_check_scattering
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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).
<<Beams: beam data: TBP>>=
procedure :: get_n_in => beam_data_get_n_in
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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
<<Beams: beam data: TBP>>=
procedure :: get_flavor => beam_data_get_flavor
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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
<<Beams: beam data: TBP>>=
procedure :: get_energy => beam_data_get_energy
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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.
<<Beams: beam data: TBP>>=
procedure :: get_sqrts => beam_data_get_sqrts
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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
<<Beams: beam data: TBP>>=
procedure :: get_polarization => beam_data_get_polarization
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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
@
<<Beams: beam data: TBP>>=
procedure :: get_helicity_state_matrix => beam_data_get_helicity_state_matrix
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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
@
<<Beams: beam data: TBP>>=
procedure :: is_initialized => beam_data_is_initialized
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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.
<<Beams: beam data: TBP>>=
procedure :: get_md5sum => beam_data_get_md5sum
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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.
<<Beams: beam data: TBP>>=
procedure :: init_structure => beam_data_init_structure
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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.
<<Beams: beam data: TBP>>=
procedure :: init_sqrts => beam_data_init_sqrts
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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.
<<Beams: beam data: TBP>>=
procedure :: init_momenta => beam_data_init_momenta
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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.
<<Beams: procedures>>=
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.
<<Beams: beam data: TBP>>=
procedure :: compute_md5sum => beam_data_compute_md5sum
<<Beams: sub interfaces>>=
module subroutine beam_data_compute_md5sum (beam_data)
class(beam_data_t), intent(inout) :: beam_data
integer :: unit
end subroutine beam_data_compute_md5sum
<<Beams: procedures>>=
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.
<<Beams: beam data: TBP>>=
procedure :: init_decay => beam_data_init_decay
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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.
<<Beams: public>>=
public :: beam_t
<<Beams: types>>=
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.
<<Beams: public>>=
public :: beam_init
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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:
<<Beams: public>>=
public :: beam_final
<<Beams: sub interfaces>>=
module subroutine beam_final (beam)
type(beam_t), intent(inout) :: beam
end subroutine beam_final
<<Beams: procedures>>=
module subroutine beam_final (beam)
type(beam_t), intent(inout) :: beam
call beam%int%final ()
end subroutine beam_final
@ %def beam_final
@ I/O:
<<Beams: public>>=
public :: beam_write
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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
<<Beams: public>>=
public :: assignment(=)
<<Beams: interfaces>>=
interface assignment(=)
module procedure beam_assign
end interface
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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}
<<Beams: public>>=
public :: interaction_set_source_link_beam
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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.
<<Beams: public>>=
public :: beam_get_int_ptr
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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.)
<<Beams: public>>=
public :: beam_set_momenta
<<Beams: sub interfaces>>=
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
<<Beams: procedures>>=
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]]>>=
<<File header>>
module beams_ut
use unit_tests
use beams_uti
<<Standard module head>>
<<Beams: public test>>
contains
<<Beams: test driver>>
end module beams_ut
@ %def beams_ut
@
<<[[beams_uti.f90]]>>=
<<File header>>
module beams_uti
<<Use kinds>>
use lorentz
use flavors
use interactions, only: reset_interaction_counter
use polarizations, only: smatrix_t
use model_data
use beam_structures
use beams
<<Standard module head>>
<<Beams: test declarations>>
contains
<<Beams: tests>>
end module beams_uti
@ %def beams_ut
@ API: driver for the unit tests below.
<<Beams: public test>>=
public :: beams_test
<<Beams: test driver>>=
subroutine beams_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Beams: execute tests>>
end subroutine beams_test
@ %def beams_test
@ Test the basic beam setup.
<<Beams: execute tests>>=
call test (beam_1, "beam_1", &
"check basic beam setup", &
u, results)
<<Beams: test declarations>>=
public :: beam_1
<<Beams: tests>>=
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.
<<Beams: execute tests>>=
call test (beam_2, "beam_2", &
"beam initialization", &
u, results)
<<Beams: test declarations>>=
public :: beam_2
<<Beams: tests>>=
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.
<<Beams: execute tests>>=
call test (beam_3, "beam_3", &
"generic beam momenta", &
u, results)
<<Beams: test declarations>>=
public :: beam_3
<<Beams: tests>>=
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]]>>=
<<File header>>
module sf_aux
<<Use kinds>>
use constants, only: twopi
use lorentz
<<Standard module head>>
<<SF aux: public>>
<<SF aux: parameters>>
<<SF aux: types>>
interface
<<SF aux: sub interfaces>>
end interface
end module sf_aux
@ %def sf_aux
@
<<[[sf_aux_sub.f90]]>>=
<<File header>>
submodule (sf_aux) sf_aux_s
use io_units
use numeric_utils
implicit none
contains
<<SF aux: procedures>>
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.
<<SF aux: public>>=
public :: splitting_data_t
<<SF aux: types>>=
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
<<SF aux: splitting data: TBP>>
end type splitting_data_t
@ %def splitting_data_t
@ I/O for debugging:
<<SF aux: splitting data: TBP>>=
procedure :: write => splitting_data_write
<<SF aux: sub interfaces>>=
module subroutine splitting_data_write (d, unit)
class(splitting_data_t), intent(in) :: d
integer, intent(in), optional :: unit
end subroutine splitting_data_write
<<SF aux: procedures>>=
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.
<<SF aux: splitting data: TBP>>=
procedure :: init => splitting_data_init
<<SF aux: sub interfaces>>=
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
<<SF aux: procedures>>=
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.
<<SF aux: splitting data: TBP>>=
procedure :: get_x_bounds => splitting_get_x_bounds
<<SF aux: sub interfaces>>=
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
<<SF aux: procedures>>=
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.
<<SF aux: splitting data: TBP>>=
procedure :: set_t_bounds => splitting_set_t_bounds
<<SF aux: sub interfaces>>=
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
<<SF aux: procedures>>=
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.
<<SF aux: splitting data: TBP>>=
procedure :: sample_t => splitting_sample_t
<<SF aux: sub interfaces>>=
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
<<SF aux: procedures>>=
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.
<<SF aux: splitting data: TBP>>=
procedure :: inverse_t => splitting_inverse_t
<<SF aux: sub interfaces>>=
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
<<SF aux: procedures>>=
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:
<<SF aux: splitting data: TBP>>=
procedure :: sample_phi => splitting_sample_phi
<<SF aux: sub interfaces>>=
module subroutine splitting_sample_phi (d, r)
class(splitting_data_t), intent(inout) :: d
real(default), intent(in) :: r
end subroutine splitting_sample_phi
<<SF aux: procedures>>=
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:
<<SF aux: splitting data: TBP>>=
procedure :: inverse_phi => splitting_inverse_phi
<<SF aux: sub interfaces>>=
module subroutine splitting_inverse_phi (d, r)
class(splitting_data_t), intent(in) :: d
real(default), intent(out) :: r
end subroutine splitting_inverse_phi
<<SF aux: procedures>>=
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.
<<SF aux: splitting data: TBP>>=
procedure :: split_momentum => splitting_split_momentum
<<SF aux: sub interfaces>>=
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
<<SF aux: procedures>>=
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.
<<SF aux: parameters>>=
integer, parameter, public :: KEEP_ENERGY = 0, KEEP_MOMENTUM = 1
@ %def KEEP_ENERGY KEEP_MOMENTUM
<<SF aux: public>>=
public :: on_shell
<<SF aux: sub interfaces>>=
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
<<SF aux: procedures>>=
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.
<<SF aux: splitting data: TBP>>=
procedure :: recover => splitting_recover
<<SF aux: sub interfaces>>=
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
<<SF aux: procedures>>=
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}
<<SF aux: splitting data: TBP>>=
procedure :: get_x => splitting_get_x
procedure :: get_xb => splitting_get_xb
<<SF aux: sub interfaces>>=
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
<<SF aux: procedures>>=
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]]>>=
<<File header>>
module sf_aux_ut
use unit_tests
use sf_aux_uti
<<Standard module head>>
<<SF aux: public test>>
contains
<<SF aux: test driver>>
end module sf_aux_ut
@ %def sf_aux_ut
@
<<[[sf_aux_uti.f90]]>>=
<<File header>>
module sf_aux_uti
<<Use kinds>>
use numeric_utils, only: pacify
use lorentz
use sf_aux
<<Standard module head>>
<<SF aux: test declarations>>
contains
<<SF aux: tests>>
end module sf_aux_uti
@ %def sf_aux_ut
@ API: driver for the unit tests below.
<<SF aux: public test>>=
public :: sf_aux_test
<<SF aux: test driver>>=
subroutine sf_aux_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF aux: execute tests>>
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.
<<SF aux: execute tests>>=
call test (sf_aux_1, "sf_aux_1", &
"massless radiation", &
u, results)
<<SF aux: test declarations>>=
public :: sf_aux_1
<<SF aux: tests>>=
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.
<<SF aux: execute tests>>=
call test (sf_aux_2, "sf_aux_2", &
"massless parton", &
u, results)
<<SF aux: test declarations>>=
public :: sf_aux_2
<<SF aux: tests>>=
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.
<<SF aux: execute tests>>=
call test (sf_aux_3, "sf_aux_3", &
"massless parton", &
u, results)
<<SF aux: test declarations>>=
public :: sf_aux_3
<<SF aux: tests>>=
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.
<<SF aux: execute tests>>=
call test (sf_aux_4, "sf_aux_4", &
"endpoint numerics", &
u, results)
<<SF aux: test declarations>>=
public :: sf_aux_4
<<SF aux: tests>>=
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]]>>=
<<File header>>
module sf_mappings
<<Use kinds>>
use kinds, only: double
<<Standard module head>>
<<SF mappings: public>>
<<SF mappings: parameters>>
<<SF mappings: types>>
<<SF mappings: interfaces>>
interface
<<SF mappings: sub interfaces>>
end interface
contains
<<SF mappings: main procedures>>
end module sf_mappings
@ %def sf_mappings
@
<<[[sf_mappings_sub.f90]]>>=
<<File header>>
submodule (sf_mappings) sf_mappings_s
use io_units
use constants, only: pi, zero, one
use numeric_utils
use diagnostics
implicit none
contains
<<SF mappings: procedures>>
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.
<<SF mappings: public>>=
public :: sf_mapping_t
<<SF mappings: types>>=
type, abstract :: sf_mapping_t
integer, dimension(:), allocatable :: i
contains
<<SF mappings: sf mapping: TBP>>
end type sf_mapping_t
@ %def sf_mapping_t
@ The output routine is deferred:
<<SF mappings: sf mapping: TBP>>=
procedure (sf_mapping_write), deferred :: write
<<SF mappings: interfaces>>=
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.
<<SF mappings: sf mapping: TBP>>=
procedure :: base_init => sf_mapping_base_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf mapping: TBP>>=
procedure :: set_index => sf_mapping_set_index
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf mapping: TBP>>=
procedure :: get_index => sf_mapping_get_index
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf mapping: TBP>>=
procedure :: get_n_dim => sf_mapping_get_n_dim
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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]].
<<SF mappings: sf mapping: TBP>>=
procedure (sf_mapping_compute), deferred :: compute
<<SF mappings: interfaces>>=
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]].
<<SF mappings: sf mapping: TBP>>=
procedure (sf_mapping_inverse), deferred :: inverse
<<SF mappings: interfaces>>=
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.
<<SF mappings: sf mapping: TBP>>=
procedure :: check => sf_mapping_check
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf mapping: TBP>>=
procedure :: integral => sf_mapping_integral
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: sf_s_mapping_t
<<SF mappings: types>>=
type, extends (sf_mapping_t) :: sf_s_mapping_t
logical :: power_set = .false.
real(default) :: power = 1
contains
<<SF mappings: sf standard mapping: TBP>>
end type sf_s_mapping_t
@ %def sf_s_mapping_t
@ Output.
<<SF mappings: sf standard mapping: TBP>>=
procedure :: write => sf_s_mapping_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf standard mapping: TBP>>=
procedure :: init => sf_s_mapping_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf standard mapping: TBP>>=
procedure :: compute => sf_s_mapping_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf standard mapping: TBP>>=
procedure :: inverse => sf_s_mapping_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: sf_res_mapping_t
<<SF mappings: types>>=
type, extends (sf_mapping_t) :: sf_res_mapping_t
real(default) :: m = 0
real(default) :: w = 0
contains
<<SF mappings: sf resonance mapping: TBP>>
end type sf_res_mapping_t
@ %def sf_res_mapping_t
@ Output.
<<SF mappings: sf resonance mapping: TBP>>=
procedure :: write => sf_res_mapping_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf resonance mapping: TBP>>=
procedure :: init => sf_res_mapping_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf resonance mapping: TBP>>=
procedure :: compute => sf_res_mapping_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf resonance mapping: TBP>>=
procedure :: inverse => sf_res_mapping_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: sf_res_mapping_single_t
<<SF mappings: types>>=
type, extends (sf_mapping_t) :: sf_res_mapping_single_t
real(default) :: m = 0
real(default) :: w = 0
contains
<<SF mappings: sf resonance single mapping: TBP>>
end type sf_res_mapping_single_t
@ %def sf_res_mapping_single_t
@ Output.
<<SF mappings: sf resonance single mapping: TBP>>=
procedure :: write => sf_res_mapping_single_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf resonance single mapping: TBP>>=
procedure :: init => sf_res_mapping_single_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf resonance single mapping: TBP>>=
procedure :: compute => sf_res_mapping_single_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf resonance single mapping: TBP>>=
procedure :: inverse => sf_res_mapping_single_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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$.
<<SF mappings: public>>=
public :: sf_os_mapping_t
<<SF mappings: types>>=
type, extends (sf_mapping_t) :: sf_os_mapping_t
real(default) :: m = 0
real(default) :: lm2 = 0
contains
<<SF mappings: sf on-shell mapping: TBP>>
end type sf_os_mapping_t
@ %def sf_os_mapping_t
@ Output.
<<SF mappings: sf on-shell mapping: TBP>>=
procedure :: write => sf_os_mapping_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf on-shell mapping: TBP>>=
procedure :: init => sf_os_mapping_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf on-shell mapping: TBP>>=
procedure :: compute => sf_os_mapping_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf on-shell mapping: TBP>>=
procedure :: inverse => sf_os_mapping_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: sf_os_mapping_single_t
<<SF mappings: types>>=
type, extends (sf_mapping_t) :: sf_os_mapping_single_t
real(default) :: m = 0
real(default) :: lm2 = 0
contains
<<SF mappings: sf on-shell mapping single: TBP>>
end type sf_os_mapping_single_t
@ %def sf_os_mapping_single_t
@ Output.
<<SF mappings: sf on-shell mapping single: TBP>>=
procedure :: write => sf_os_mapping_single_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf on-shell mapping single: TBP>>=
procedure :: init => sf_os_mapping_single_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf on-shell mapping single: TBP>>=
procedure :: compute => sf_os_mapping_single_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf on-shell mapping single: TBP>>=
procedure :: inverse => sf_os_mapping_single_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: sf_ep_mapping_t
<<SF mappings: types>>=
type, extends (sf_mapping_t) :: sf_ep_mapping_t
real(default) :: a = 1
contains
<<SF mappings: sf endpoint mapping: TBP>>
end type sf_ep_mapping_t
@ %def sf_ep_mapping_t
@ Output.
<<SF mappings: sf endpoint mapping: TBP>>=
procedure :: write => sf_ep_mapping_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf endpoint mapping: TBP>>=
procedure :: init => sf_ep_mapping_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf endpoint mapping: TBP>>=
procedure :: compute => sf_ep_mapping_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf endpoint mapping: TBP>>=
procedure :: inverse => sf_ep_mapping_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: sf_epr_mapping_t
<<SF mappings: types>>=
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
<<SF mappings: sf endpoint/res mapping: TBP>>
end type sf_epr_mapping_t
@ %def sf_epr_mapping_t
@ Output.
<<SF mappings: sf endpoint/res mapping: TBP>>=
procedure :: write => sf_epr_mapping_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf endpoint/res mapping: TBP>>=
procedure :: init => sf_epr_mapping_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf endpoint/res mapping: TBP>>=
procedure :: compute => sf_epr_mapping_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf endpoint/res mapping: TBP>>=
procedure :: inverse => sf_epr_mapping_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: sf_epo_mapping_t
<<SF mappings: types>>=
type, extends (sf_mapping_t) :: sf_epo_mapping_t
real(default) :: a = 1
real(default) :: m = 0
real(default) :: lm2 = 0
contains
<<SF mappings: sf endpoint/os mapping: TBP>>
end type sf_epo_mapping_t
@ %def sf_epo_mapping_t
@ Output.
<<SF mappings: sf endpoint/os mapping: TBP>>=
procedure :: write => sf_epo_mapping_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf endpoint/os mapping: TBP>>=
procedure :: init => sf_epo_mapping_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf endpoint/os mapping: TBP>>=
procedure :: compute => sf_epo_mapping_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf endpoint/os mapping: TBP>>=
procedure :: inverse => sf_epo_mapping_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: sf_ip_mapping_t
<<SF mappings: types>>=
type, extends (sf_mapping_t) :: sf_ip_mapping_t
real(default) :: eps = 0
contains
<<SF mappings: sf power mapping: TBP>>
end type sf_ip_mapping_t
@ %def sf_ip_mapping_t
@ Output.
<<SF mappings: sf power mapping: TBP>>=
procedure :: write => sf_ip_mapping_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf power mapping: TBP>>=
procedure :: init => sf_ip_mapping_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf power mapping: TBP>>=
procedure :: compute => sf_ip_mapping_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf power mapping: TBP>>=
procedure :: inverse => sf_ip_mapping_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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]].
<<SF mappings: public>>=
public :: sf_ipr_mapping_t
<<SF mappings: types>>=
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
<<SF mappings: sf power/res mapping: TBP>>
end type sf_ipr_mapping_t
@ %def sf_ipr_mapping_t
@ Output.
<<SF mappings: sf power/res mapping: TBP>>=
procedure :: write => sf_ipr_mapping_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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:
<<SF mappings: sf power/res mapping: TBP>>=
procedure :: init => sf_ipr_mapping_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf power/res mapping: TBP>>=
procedure :: compute => sf_ipr_mapping_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf power/res mapping: TBP>>=
procedure :: inverse => sf_ipr_mapping_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: sf_ipo_mapping_t
<<SF mappings: types>>=
type, extends (sf_mapping_t) :: sf_ipo_mapping_t
real(default) :: eps = 0
real(default) :: m = 0
contains
<<SF mappings: sf power/os mapping: TBP>>
end type sf_ipo_mapping_t
@ %def sf_ipo_mapping_t
@ Output.
<<SF mappings: sf power/os mapping: TBP>>=
procedure :: write => sf_ipo_mapping_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf power/os mapping: TBP>>=
procedure :: init => sf_ipo_mapping_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf power/os mapping: TBP>>=
procedure :: compute => sf_ipo_mapping_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf power/os mapping: TBP>>=
procedure :: inverse => sf_ipo_mapping_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: sf_ei_mapping_t
<<SF mappings: types>>=
type, extends (sf_mapping_t) :: sf_ei_mapping_t
type(sf_ep_mapping_t) :: ep
type(sf_ip_mapping_t) :: ip
contains
<<SF mappings: sf ep-ip mapping: TBP>>
end type sf_ei_mapping_t
@ %def sf_ei_mapping_t
@ Output.
<<SF mappings: sf ep-ip mapping: TBP>>=
procedure :: write => sf_ei_mapping_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf ep-ip mapping: TBP>>=
procedure :: init => sf_ei_mapping_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf ep-ip mapping: TBP>>=
procedure :: set_index => sf_ei_mapping_set_index
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf ep-ip mapping: TBP>>=
procedure :: compute => sf_ei_mapping_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf ep-ip mapping: TBP>>=
procedure :: inverse => sf_ei_mapping_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: sf_eir_mapping_t
<<SF mappings: types>>=
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
<<SF mappings: sf ep-ip-res mapping: TBP>>
end type sf_eir_mapping_t
@ %def sf_eir_mapping_t
@ Output.
<<SF mappings: sf ep-ip-res mapping: TBP>>=
procedure :: write => sf_eir_mapping_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf ep-ip-res mapping: TBP>>=
procedure :: init => sf_eir_mapping_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf ep-ip-res mapping: TBP>>=
procedure :: set_index => sf_eir_mapping_set_index
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf ep-ip-res mapping: TBP>>=
procedure :: compute => sf_eir_mapping_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf ep-ip-res mapping: TBP>>=
procedure :: inverse => sf_eir_mapping_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: sf_eio_mapping_t
<<SF mappings: types>>=
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
<<SF mappings: sf ep-ip-os mapping: TBP>>
end type sf_eio_mapping_t
@ %def sf_eio_mapping_t
@ Output.
<<SF mappings: sf ep-ip-os mapping: TBP>>=
procedure :: write => sf_eio_mapping_write
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf ep-ip-os mapping: TBP>>=
procedure :: init => sf_eio_mapping_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf ep-ip-os mapping: TBP>>=
procedure :: set_index => sf_eio_mapping_set_index
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf ep-ip-os mapping: TBP>>=
procedure :: compute => sf_eio_mapping_compute
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf ep-ip-os mapping: TBP>>=
procedure :: inverse => sf_eio_mapping_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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}
<<SF mappings: procedures>>=
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.
<<SF mappings: procedures>>=
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.
<<SF mappings: procedures>>=
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.
<<SF mappings: procedures>>=
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.
<<SF mappings: procedures>>=
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.
<<SF mappings: procedures>>=
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<r_2$ here; for the opposite case, the arguments can be
exchanged.)
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: map_on_shell
public :: map_on_shell_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: map_on_shell_single
public :: map_on_shell_single_inverse
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: procedures>>=
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$.
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: map_power_1
public :: map_power_inverse_1
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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$.
<<SF mappings: procedures>>=
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}
<<SF mappings: parameters>>=
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.
<<SF mappings: public>>=
public :: sf_channel_t
<<SF mappings: types>>=
type :: sf_channel_t
integer, dimension(:), allocatable :: map_code
class(sf_mapping_t), allocatable :: multi_mapping
contains
<<SF mappings: sf channel: TBP>>
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.
<<SF mappings: sf channel: TBP>>=
procedure :: write => sf_channel_write
<<SF mappings: sub interfaces>>=
module subroutine sf_channel_write (object, unit)
class(sf_channel_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine sf_channel_write
<<SF mappings: procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: init => sf_channel_init
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
generic :: assignment (=) => sf_channel_assign
procedure :: sf_channel_assign
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: allocate_sf_channels
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: activate_mapping => sf_channel_activate_mapping
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_s_mapping => sf_channel_set_s_mapping
<<SF mappings: main procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_res_mapping => sf_channel_set_res_mapping
<<SF mappings: main procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_os_mapping => sf_channel_set_os_mapping
<<SF mappings: main procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_ep_mapping => sf_channel_set_ep_mapping
<<SF mappings: main procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_epr_mapping => sf_channel_set_epr_mapping
<<SF mappings: main procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_epo_mapping => sf_channel_set_epo_mapping
<<SF mappings: main procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_ip_mapping => sf_channel_set_ip_mapping
<<SF mappings: main procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_ipr_mapping => sf_channel_set_ipr_mapping
<<SF mappings: main procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_ipo_mapping => sf_channel_set_ipo_mapping
<<SF mappings: main procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_ei_mapping => sf_channel_set_ei_mapping
<<SF mappings: main procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_eir_mapping => sf_channel_set_eir_mapping
<<SF mappings: main procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_eio_mapping => sf_channel_set_eio_mapping
<<SF mappings: main procedures>>=
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]].
<<SF mappings: sf channel: TBP>>=
procedure :: is_single_mapping => sf_channel_is_single_mapping
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: is_multi_mapping => sf_channel_is_multi_mapping
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: get_multi_mapping_n_par => sf_channel_get_multi_mapping_n_par
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: public>>=
public :: any_sf_channel_has_mapping
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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.
<<SF mappings: sf channel: TBP>>=
procedure :: set_par_index => sf_channel_set_par_index
<<SF mappings: sub interfaces>>=
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
<<SF mappings: procedures>>=
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]]>>=
<<File header>>
module sf_mappings_ut
use unit_tests
use sf_mappings_uti
<<Standard module head>>
<<SF mappings: public test>>
contains
<<SF mappings: test driver>>
end module sf_mappings_ut
@ %def sf_mappings_ut
@
<<[[sf_mappings_uti.f90]]>>=
<<File header>>
module sf_mappings_uti
<<Use kinds>>
use format_defs, only: FMT_11, FMT_12, FMT_13, FMT_14, FMT_15, FMT_16
use sf_mappings
<<Standard module head>>
<<SF mappings: test declarations>>
contains
<<SF mappings: tests>>
end module sf_mappings_uti
@ %def sf_mappings_ut
@ API: driver for the unit tests below.
<<SF mappings: public test>>=
public :: sf_mappings_test
<<SF mappings: test driver>>=
subroutine sf_mappings_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF mappings: execute tests>>
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_1, "sf_mappings_1", &
"standard pair mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_1
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_2, "sf_mappings_2", &
"structure-function mapping channels", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_2
<<SF mappings: tests>>=
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$.
<<SF mappings: execute tests>>=
call test (sf_mappings_3, "sf_mappings_3", &
"resonant pair mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_3
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_4, "sf_mappings_4", &
"on-shell pair mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_4
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_5, "sf_mappings_5", &
"endpoint pair mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_5
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_6, "sf_mappings_6", &
"endpoint resonant mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_6
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_7, "sf_mappings_7", &
"endpoint on-shell mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_7
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_8, "sf_mappings_8", &
"power pair mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_8
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_9, "sf_mappings_9", &
"power resonance mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_9
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_10, "sf_mappings_10", &
"power on-shell mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_10
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_11, "sf_mappings_11", &
"endpoint/power combined mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_11
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_12, "sf_mappings_12", &
"endpoint/power resonant combined mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_12
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_13, "sf_mappings_13", &
"endpoint/power on-shell combined mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_13
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_14, "sf_mappings_14", &
"rescaled on-shell mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_14
<<SF mappings: tests>>=
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$.
<<SF mappings: execute tests>>=
call test (sf_mappings_15, "sf_mappings_15", &
"resonant single mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_15
<<SF mappings: tests>>=
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.
<<SF mappings: execute tests>>=
call test (sf_mappings_16, "sf_mappings_16", &
"on-shell single mapping", &
u, results)
<<SF mappings: test declarations>>=
public :: sf_mappings_16
<<SF mappings: tests>>=
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]]>>=
<<File header>>
module sf_base
<<Use kinds>>
<<Use strings>>
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
<<Standard module head>>
<<SF base: public>>
<<SF base: parameters>>
<<SF base: types>>
<<SF base: interfaces>>
interface
<<SF base: sub interfaces>>
end interface
end module sf_base
@ %def sf_base
@
<<[[sf_base_sub.f90]]>>=
<<File header>>
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
<<SF base: procedures>>
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.
<<SF base: public>>=
public :: sf_rescale_t
<<SF base: types>>=
type, abstract :: sf_rescale_t
integer :: i_beam = 0
contains
<<SF base: rescaling function: TBP>>
end type sf_rescale_t
@ %def sf_rescale_t
@
<<SF base: rescaling function: TBP>>=
procedure (sf_rescale_apply), deferred :: apply
<<SF base: interfaces>>=
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
@
<<SF base: rescaling function: TBP>>=
procedure :: set_i_beam => sf_rescale_set_i_beam
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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
@
<<SF base: public>>=
public :: sf_rescale_collinear_t
<<SF base: types>>=
type, extends (sf_rescale_t) :: sf_rescale_collinear_t
real(default) :: xi_tilde
contains
<<SF base: rescale collinear: TBP>>
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]].
<<SF base: rescale collinear: TBP>>=
procedure :: apply => sf_rescale_collinear_apply
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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
@
<<SF base: rescale collinear: TBP>>=
procedure :: set => sf_rescale_collinear_set
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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
@
<<SF base: public>>=
public :: sf_rescale_real_t
<<SF base: types>>=
type, extends (sf_rescale_t) :: sf_rescale_real_t
real(default) :: xi, y
contains
<<SF base: rescale real: TBP>>
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}
<<SF base: rescale real: TBP>>=
procedure :: apply => sf_rescale_real_apply
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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
@
<<SF base: rescale real: TBP>>=
procedure :: set => sf_rescale_real_set
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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
<<SF base: public>>=
public :: sf_rescale_dglap_t
<<SF base: types>>=
type, extends(sf_rescale_t) :: sf_rescale_dglap_t
real(default), dimension(:), allocatable :: z
contains
<<SF base: rescale dglap: TBP>>
end type sf_rescale_dglap_t
@ %def sf_rescale_dglap_t
@
<<SF base: rescale dglap: TBP>>=
procedure :: apply => sf_rescale_dglap_apply
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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
@
<<SF base: rescale dglap: TBP>>=
procedure :: set => sf_rescale_dglap_set
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: public>>=
public :: sf_data_t
<<SF base: types>>=
type, abstract :: sf_data_t
contains
<<SF base: sf data: TBP>>
end type sf_data_t
@ %def sf_data_t
@ Output.
<<SF base: sf data: TBP>>=
procedure (sf_data_write), deferred :: write
<<SF base: interfaces>>=
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.
<<SF base: sf data: TBP>>=
procedure :: is_generator => sf_data_is_generator
<<SF base: sub interfaces>>=
module function sf_data_is_generator (data) result (flag)
class(sf_data_t), intent(in) :: data
logical :: flag
end function sf_data_is_generator
<<SF base: procedures>>=
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.
<<SF base: sf data: TBP>>=
procedure (sf_data_get_int), deferred :: get_n_par
<<SF base: interfaces>>=
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.
<<SF base: sf data: TBP>>=
procedure (sf_data_get_pdg_out), deferred :: get_pdg_out
<<SF base: interfaces>>=
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.
<<SF base: sf data: TBP>>=
procedure (sf_data_allocate_sf_int), deferred :: allocate_sf_int
<<SF base: interfaces>>=
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.
<<SF base: sf data: TBP>>=
procedure :: get_pdf_set => sf_data_get_pdf_set
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf data: TBP>>=
procedure :: get_beam_file => sf_data_get_beam_file
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: public>>=
public :: sf_config_t
<<SF base: types>>=
type :: sf_config_t
integer, dimension(:), allocatable :: i
class(sf_data_t), allocatable :: data
contains
<<SF base: sf config: TBP>>
end type sf_config_t
@ %def sf_config_t
@ Output:
<<SF base: sf config: TBP>>=
procedure :: write => sf_config_write
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf config: TBP>>=
procedure :: init => sf_config_init
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf config: TBP>>=
procedure :: get_pdf_set => sf_config_get_pdf_set
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf config: TBP>>=
procedure :: get_beam_file => sf_config_get_beam_file
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: public>>=
public :: sf_int_t
<<SF base: types>>=
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
<<SF base: sf int: TBP>>
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.
<<SF base: parameters>>=
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:
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure :: base_write => sf_int_base_write
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure (sf_int_type_string), deferred :: type_string
<<SF base: interfaces>>=
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.
<<SF base: sf int: TBP>>=
procedure (sf_int_write), deferred :: write
<<SF base: interfaces>>=
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.
<<SF base: sf int: TBP>>=
procedure :: base_init => sf_int_base_init
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure :: set_incoming => sf_int_set_incoming
procedure :: set_radiated => sf_int_set_radiated
procedure :: set_outgoing => sf_int_set_outgoing
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure (sf_int_init), deferred :: init
<<SF base: interfaces>>=
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.
<<SF base: sf int: TBP>>=
procedure :: setup_constants => sf_int_setup_constants
<<SF base: sub interfaces>>=
module subroutine sf_int_setup_constants (sf_int)
class(sf_int_t), intent(inout), target :: sf_int
end subroutine sf_int_setup_constants
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure :: set_beam_index => sf_int_set_beam_index
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure :: set_par_index => sf_int_set_par_index
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
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
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure :: is_generator => sf_int_is_generator
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure :: generate_free => sf_int_generate_free
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure (sf_int_complete_kinematics), deferred :: complete_kinematics
procedure (sf_int_inverse_kinematics), deferred :: inverse_kinematics
<<SF base: interfaces>>=
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.
<<SF base: sf int: TBP>>=
procedure :: split_momentum => sf_int_split_momentum
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure :: split_momenta => sf_int_split_momenta
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure :: reduce_momenta => sf_int_reduce_momenta
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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
<<SF base: sf int: TBP>>=
procedure :: recover_x => sf_int_recover_x
procedure :: base_recover_x => sf_int_recover_x
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure (sf_int_apply), deferred :: apply
<<SF base: interfaces>>=
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.
<<SF base: sf int: TBP>>=
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
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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:
<<SF base: sf int: TBP>>=
procedure :: get_n_states => sf_int_get_n_states
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure :: get_state => sf_int_get_state
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure :: get_values => sf_int_get_values
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure :: compute_values => sf_int_compute_values
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf int: TBP>>=
procedure :: compute_value => sf_int_compute_value
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: types>>=
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.
<<SF base: public>>=
public :: sf_chain_t
<<SF base: types>>=
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
<<SF base: sf chain: TBP>>
end type sf_chain_t
@ %def sf_chain_t
@ Finalizer.
<<SF base: sf chain: TBP>>=
procedure :: final => sf_chain_final
<<SF base: sub interfaces>>=
module subroutine sf_chain_final (object)
class(sf_chain_t), intent(inout) :: object
end subroutine sf_chain_final
<<SF base: procedures>>=
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.
<<SF base: sf chain: TBP>>=
procedure :: write => sf_chain_write
<<SF base: sub interfaces>>=
module subroutine sf_chain_write (object, unit)
class(sf_chain_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine sf_chain_write
<<SF base: procedures>>=
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.
<<SF base: sf chain: TBP>>=
procedure :: init => sf_chain_init
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain: TBP>>=
procedure :: receive_beam_momenta => sf_chain_receive_beam_momenta
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain: TBP>>=
procedure :: set_beam_momenta => sf_chain_set_beam_momenta
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain: TBP>>=
procedure :: set_strfun => sf_chain_set_strfun
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain: TBP>>=
procedure :: get_n_par => sf_chain_get_n_par
procedure :: get_n_bound => sf_chain_get_n_bound
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain: TBP>>=
procedure :: get_beam_int_ptr => sf_chain_get_beam_int_ptr
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain: TBP>>=
procedure :: setup_tracing => sf_chain_setup_tracing
procedure :: final_tracing => sf_chain_final_tracing
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain: TBP>>=
procedure :: write_trace_header => sf_chain_write_trace_header
<<SF base: sub interfaces>>=
module subroutine sf_chain_write_trace_header (sf_chain)
class(sf_chain_t), intent(in) :: sf_chain
end subroutine sf_chain_write_trace_header
<<SF base: procedures>>=
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.
<<SF base: sf chain: TBP>>=
procedure :: trace => sf_chain_trace
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: public>>=
public :: sf_chain_instance_t
<<SF base: types>>=
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
<<SF base: sf chain instance: TBP>>
end type sf_chain_instance_t
@ %def sf_chain_instance_t
@ Finalizer.
<<SF base: sf chain instance: TBP>>=
procedure :: final => sf_chain_instance_final
<<SF base: sub interfaces>>=
module subroutine sf_chain_instance_final (object)
class(sf_chain_instance_t), intent(inout) :: object
end subroutine sf_chain_instance_final
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: write => sf_chain_instance_write
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: init => sf_chain_instance_init
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: select_channel => sf_chain_instance_select_channel
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: set_channel => sf_chain_instance_set_channel
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: link_interactions => sf_chain_instance_link_interactions
<<SF base: sub interfaces>>=
module subroutine sf_chain_instance_link_interactions (chain)
class(sf_chain_instance_t), intent(inout), target :: chain
end subroutine sf_chain_instance_link_interactions
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: exchange_mask => sf_chain_exchange_mask
<<SF base: sub interfaces>>=
module subroutine sf_chain_exchange_mask (chain)
class(sf_chain_instance_t), intent(inout), target :: chain
end subroutine sf_chain_exchange_mask
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: init_evaluators => sf_chain_instance_init_evaluators
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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
<<SF base: init evaluators: find outgoing particles>>
end subroutine sf_chain_instance_init_evaluators
@ %def sf_chain_instance_init_evaluators
@ For debug purposes
<<SF base: sf chain instance: TBP>>=
procedure :: write_interaction => sf_chain_instance_write_interaction
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: init evaluators: find outgoing particles>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: compute_kinematics => sf_chain_instance_compute_kinematics
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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]].
<<SF base: sf chain instance: TBP>>=
procedure :: inverse_kinematics => sf_chain_instance_inverse_kinematics
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: recover_kinematics => sf_chain_instance_recover_kinematics
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: return_beam_momenta => sf_chain_instance_return_beam_momenta
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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
+For the collinear final or initial 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.
<<SF base: sf chain instance: TBP>>=
procedure :: evaluate => sf_chain_instance_evaluate
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: get_out_momenta => sf_chain_instance_get_out_momenta
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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).
<<SF base: sf chain instance: TBP>>=
procedure :: get_out_int_ptr => sf_chain_instance_get_out_int_ptr
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: get_out_i => sf_chain_instance_get_out_i
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: get_out_mask => sf_chain_instance_get_out_mask
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: get_mcpar => sf_chain_instance_get_mcpar
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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]].
<<SF base: sf chain instance: TBP>>=
procedure :: get_f => sf_chain_instance_get_f
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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.
<<SF base: sf chain instance: TBP>>=
procedure :: get_status => sf_chain_instance_get_status
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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
@
<<SF base: sf chain instance: TBP>>=
procedure :: get_matrix_elements => sf_chain_instance_get_matrix_elements
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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
@
<<SF base: sf chain instance: TBP>>=
procedure :: get_beam_int_ptr => sf_chain_instance_get_beam_int_ptr
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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
@
<<SF base: sf chain instance: TBP>>=
procedure :: get_n_sub => sf_chain_instance_get_n_sub
<<SF base: sub interfaces>>=
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
<<SF base: procedures>>=
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]]>>=
<<File header>>
module sf_base_ut
use unit_tests
use sf_base_uti
<<Standard module head>>
<<SF base: public test auxiliary>>
<<SF base: public test>>
contains
<<SF base: test driver>>
end module sf_base_ut
@ %def sf_base_ut
@
<<[[sf_base_uti.f90]]>>=
<<File header>>
module sf_base_uti
<<Use kinds>>
<<Use strings>>
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
<<Standard module head>>
<<SF base: test declarations>>
<<SF base: public test auxiliary>>
<<SF base: test types>>
contains
<<SF base: tests>>
<<SF base: test auxiliary>>
end module sf_base_uti
@ %def sf_base_ut
@ API: driver for the unit tests below.
<<SF base: public test>>=
public :: sf_base_test
<<SF base: test driver>>=
subroutine sf_base_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF base: execute tests>>
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.
<<SF base: public test auxiliary>>=
public :: sf_test_data_t
<<SF base: test types>>=
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
<<SF base: sf test data: TBP>>
end type sf_test_data_t
@ %def sf_test_data_t
@ Output.
<<SF base: sf test data: TBP>>=
procedure :: write => sf_test_data_write
<<SF base: test auxiliary>>=
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.
<<SF base: sf test data: TBP>>=
procedure :: init => sf_test_data_init
<<SF base: test auxiliary>>=
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.
<<SF base: sf test data: TBP>>=
procedure :: get_n_par => sf_test_data_get_n_par
<<SF base: test auxiliary>>=
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
<<SF base: sf test data: TBP>>=
procedure :: get_pdg_out => sf_test_data_get_pdg_out
<<SF base: test auxiliary>>=
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.
<<SF base: sf test data: TBP>>=
procedure :: allocate_sf_int => sf_test_data_allocate_sf_int
<<SF base: test auxiliary>>=
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}
<<SF base: test types>>=
type, extends (sf_int_t) :: sf_test_t
type(sf_test_data_t), pointer :: data => null ()
real(default) :: x = 0
contains
<<SF base: sf test int: TBP>>
end type sf_test_t
@ %def sf_test_t
@ Type string: constant
<<SF base: sf test int: TBP>>=
procedure :: type_string => sf_test_type_string
<<SF base: test auxiliary>>=
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.
<<SF base: sf test int: TBP>>=
procedure :: write => sf_test_write
<<SF base: test auxiliary>>=
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.
<<SF base: sf test int: TBP>>=
procedure :: init => sf_test_init
<<SF base: test auxiliary>>=
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$.
<<SF base: sf test int: TBP>>=
procedure :: complete_kinematics => sf_test_complete_kinematics
<<SF base: test auxiliary>>=
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.
<<SF base: sf test int: TBP>>=
procedure :: inverse_kinematics => sf_test_inverse_kinematics
<<SF base: test auxiliary>>=
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$.
<<SF base: sf test int: TBP>>=
procedure :: apply => sf_test_apply
<<SF base: test auxiliary>>=
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.
<<SF base: test types>>=
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
<<SF base: sf test spectrum data: TBP>>
end type sf_test_spectrum_data_t
@ %def sf_test_spectrum_data_t
@ Output.
<<SF base: sf test spectrum data: TBP>>=
procedure :: write => sf_test_spectrum_data_write
<<SF base: test auxiliary>>=
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.
<<SF base: sf test spectrum data: TBP>>=
procedure :: init => sf_test_spectrum_data_init
<<SF base: test auxiliary>>=
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.
<<SF base: sf test spectrum data: TBP>>=
procedure :: get_n_par => sf_test_spectrum_data_get_n_par
<<SF base: test auxiliary>>=
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
<<SF base: sf test spectrum data: TBP>>=
procedure :: get_pdg_out => sf_test_spectrum_data_get_pdg_out
<<SF base: test auxiliary>>=
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.
<<SF base: sf test spectrum data: TBP>>=
procedure :: allocate_sf_int => &
sf_test_spectrum_data_allocate_sf_int
<<SF base: test auxiliary>>=
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}
<<SF base: test types>>=
type, extends (sf_int_t) :: sf_test_spectrum_t
type(sf_test_spectrum_data_t), pointer :: data => null ()
contains
<<SF base: sf test spectrum: TBP>>
end type sf_test_spectrum_t
@ %def sf_test_spectrum_t
<<SF base: sf test spectrum: TBP>>=
procedure :: type_string => sf_test_spectrum_type_string
<<SF base: test auxiliary>>=
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.
<<SF base: sf test spectrum: TBP>>=
procedure :: write => sf_test_spectrum_write
<<SF base: test auxiliary>>=
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.
<<SF base: sf test spectrum: TBP>>=
procedure :: init => sf_test_spectrum_init
<<SF base: test auxiliary>>=
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$.
<<SF base: sf test spectrum: TBP>>=
procedure :: complete_kinematics => sf_test_spectrum_complete_kinematics
<<SF base: test auxiliary>>=
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.
<<SF base: sf test spectrum: TBP>>=
procedure :: inverse_kinematics => sf_test_spectrum_inverse_kinematics
<<SF base: test auxiliary>>=
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.
<<SF base: sf test spectrum: TBP>>=
procedure :: apply => sf_test_spectrum_apply
<<SF base: test auxiliary>>=
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.
<<SF base: test types>>=
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
<<SF base: sf test generator data: TBP>>
end type sf_test_generator_data_t
@ %def sf_test_generator_data_t
@ Output.
<<SF base: sf test generator data: TBP>>=
procedure :: write => sf_test_generator_data_write
<<SF base: test auxiliary>>=
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.
<<SF base: sf test generator data: TBP>>=
procedure :: init => sf_test_generator_data_init
<<SF base: test auxiliary>>=
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.
<<SF base: sf test generator data: TBP>>=
procedure :: is_generator => sf_test_generator_data_is_generator
<<SF base: test auxiliary>>=
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.
<<SF base: sf test generator data: TBP>>=
procedure :: get_n_par => sf_test_generator_data_get_n_par
<<SF base: test auxiliary>>=
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
<<SF base: sf test generator data: TBP>>=
procedure :: get_pdg_out => sf_test_generator_data_get_pdg_out
<<SF base: test auxiliary>>=
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.
<<SF base: sf test generator data: TBP>>=
procedure :: allocate_sf_int => &
sf_test_generator_data_allocate_sf_int
<<SF base: test auxiliary>>=
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}
<<SF base: test types>>=
type, extends (sf_int_t) :: sf_test_generator_t
type(sf_test_generator_data_t), pointer :: data => null ()
contains
<<SF base: sf test generator: TBP>>
end type sf_test_generator_t
@ %def sf_test_generator_t
<<SF base: sf test generator: TBP>>=
procedure :: type_string => sf_test_generator_type_string
<<SF base: test auxiliary>>=
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.
<<SF base: sf test generator: TBP>>=
procedure :: write => sf_test_generator_write
<<SF base: test auxiliary>>=
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.
<<SF base: sf test generator: TBP>>=
procedure :: init => sf_test_generator_init
<<SF base: test auxiliary>>=
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.
<<SF base: sf test generator: TBP>>=
procedure :: is_generator => sf_test_generator_is_generator
<<SF base: test auxiliary>>=
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.
<<SF base: sf test generator: TBP>>=
procedure :: generate_free => sf_test_generator_generate_free
<<SF base: test auxiliary>>=
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.
<<SF base: sf test generator: TBP>>=
procedure :: recover_x => sf_test_generator_recover_x
<<SF base: test auxiliary>>=
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.
<<SF base: sf test generator: TBP>>=
procedure :: complete_kinematics => sf_test_generator_complete_kinematics
<<SF base: test auxiliary>>=
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.
<<SF base: sf test generator: TBP>>=
procedure :: inverse_kinematics => sf_test_generator_inverse_kinematics
<<SF base: test auxiliary>>=
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.
<<SF base: sf test generator: TBP>>=
procedure :: apply => sf_test_generator_apply
<<SF base: test auxiliary>>=
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.
<<SF base: execute tests>>=
call test (sf_base_1, "sf_base_1", &
"structure function configuration", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_1
<<SF base: tests>>=
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.
<<SF base: execute tests>>=
call test (sf_base_2, "sf_base_2", &
"structure function instance", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_2
<<SF base: tests>>=
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.
<<SF base: execute tests>>=
call test (sf_base_3, "sf_base_3", &
"alternatives for collinear kinematics", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_3
<<SF base: tests>>=
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.
<<SF base: execute tests>>=
call test (sf_base_4, "sf_base_4", &
"alternatives for non-collinear kinematics", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_4
<<SF base: tests>>=
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).
<<SF base: execute tests>>=
call test (sf_base_5, "sf_base_5", &
"pair spectrum with radiation", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_5
<<SF base: tests>>=
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).
<<SF base: execute tests>>=
call test (sf_base_6, "sf_base_6", &
"pair spectrum without radiation", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_6
<<SF base: tests>>=
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.
<<SF base: execute tests>>=
call test (sf_base_7, "sf_base_7", &
"direct access", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_7
<<SF base: tests>>=
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}
<<SF base: execute tests>>=
call test (sf_base_8, "sf_base_8", &
"structure function chain configuration", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_8
<<SF base: tests>>=
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.
<<SF base: execute tests>>=
call test (sf_base_9, "sf_base_9", &
"structure function chain instance", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_9
<<SF base: tests>>=
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.
<<SF base: execute tests>>=
call test (sf_base_10, "sf_base_10", &
"structure function chain mapping", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_10
<<SF base: tests>>=
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.
<<SF base: execute tests>>=
call test (sf_base_11, "sf_base_11", &
"structure function chain evaluation", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_11
<<SF base: tests>>=
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.
<<SF base: execute tests>>=
call test (sf_base_12, "sf_base_12", &
"multi-channel structure function chain", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_12
<<SF base: tests>>=
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.
<<SF base: execute tests>>=
call test (sf_base_13, "sf_base_13", &
"pair spectrum generator", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_13
<<SF base: tests>>=
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.
<<SF base: execute tests>>=
call test (sf_base_14, "sf_base_14", &
"structure function generator evaluation", &
u, results)
<<SF base: test declarations>>=
public :: sf_base_14
<<SF base: tests>>=
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]]>>=
<<File header>>
module sf_isr
<<Use kinds>>
<<Use strings>>
use pdg_arrays
use model_data
use flavors
use sf_aux
use sf_mappings
use sf_base
use electron_pdfs
<<Standard module head>>
<<SF isr: public>>
<<SF isr: parameters>>
<<SF isr: types>>
interface
<<SF isr: sub interfaces>>
end interface
contains
<<SF isr: main procedures>>
end module sf_isr
@ %def sf_isr
@
<<[[sf_isr_sub.f90]]>>=
<<File header>>
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
<<SF isr: procedures>>
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}
<<SF isr: public>>=
public :: isr_data_t
<<SF isr: types>>=
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
<<SF isr: isr data: TBP>>
end type isr_data_t
@ %def isr_data_t
@ Error codes
<<SF isr: parameters>>=
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:
<<SF isr: isr data: TBP>>=
procedure :: init => isr_data_init
<<SF isr: sub interfaces>>=
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
<<SF isr: procedures>>=
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, &
0, 1)
end subroutine isr_data_init
@ %def isr_data_init
@ Explicitly set ISR order
<<SF isr: isr data: TBP>>=
procedure :: set_order => isr_data_set_order
<<SF isr: sub interfaces>>=
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
<<SF isr: procedures>>=
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.
<<SF isr: isr data: TBP>>=
procedure :: check => isr_data_check
<<SF isr: sub interfaces>>=
module subroutine isr_data_check (data)
class(isr_data_t), intent(in) :: data
end subroutine isr_data_check
<<SF isr: procedures>>=
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
<<SF isr: isr data: TBP>>=
procedure :: write => isr_data_write
<<SF isr: sub interfaces>>=
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
<<SF isr: procedures>>=
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.
<<SF isr: isr data: TBP>>=
procedure :: get_n_par => isr_data_get_n_par
<<SF isr: sub interfaces>>=
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
<<SF isr: procedures>>=
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.
<<SF isr: isr data: TBP>>=
procedure :: get_pdg_out => isr_data_get_pdg_out
<<SF isr: sub interfaces>>=
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
<<SF isr: procedures>>=
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.
<<SF isr: isr data: TBP>>=
procedure :: get_eps => isr_data_get_eps
<<SF isr: sub interfaces>>=
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
<<SF isr: procedures>>=
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.
<<SF isr: isr data: TBP>>=
procedure :: allocate_sf_int => isr_data_allocate_sf_int
<<SF isr: main procedures>>=
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.
<<SF isr: public>>=
public :: isr_t
<<SF isr: types>>=
type, extends (sf_int_t) :: isr_t
private
type(isr_data_t), pointer :: data => null ()
real(default) :: x = 0
real(default) :: xb= 0
contains
<<SF isr: isr: TBP>>
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.
<<SF isr: isr: TBP>>=
procedure :: type_string => isr_type_string
<<SF isr: sub interfaces>>=
module function isr_type_string (object) result (string)
class(isr_t), intent(in) :: object
type(string_t) :: string
end function isr_type_string
<<SF isr: procedures>>=
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.
<<SF isr: isr: TBP>>=
procedure :: write => isr_write
<<SF isr: sub interfaces>>=
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
<<SF isr: procedures>>=
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).
<<SF isr: isr: TBP>>=
procedure :: set_order => isr_set_order
<<SF isr: sub interfaces>>=
module subroutine isr_set_order (object, order)
class(isr_t), intent(inout) :: object
integer, intent(in) :: order
end subroutine isr_set_order
<<SF isr: procedures>>=
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.
<<SF isr: isr: TBP>>=
procedure :: complete_kinematics => isr_complete_kinematics
<<SF isr: sub interfaces>>=
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
<<SF isr: procedures>>=
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.
<<SF isr: isr: TBP>>=
procedure :: recover_x => sf_isr_recover_x
<<SF isr: sub interfaces>>=
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
<<SF isr: procedures>>=
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).
<<SF isr: isr: TBP>>=
procedure :: inverse_kinematics => isr_inverse_kinematics
<<SF isr: sub interfaces>>=
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
<<SF isr: procedures>>=
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
@
<<SF isr: isr: TBP>>=
procedure :: init => isr_init
<<SF isr: sub interfaces>>=
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
<<SF isr: procedures>>=
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.
<<SF isr: isr: TBP>>=
procedure :: apply => isr_apply
<<SF isr: sub interfaces>>=
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
<<SF isr: procedures>>=
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]]>>=
<<File header>>
module sf_isr_ut
use unit_tests
use sf_isr_uti
<<Standard module head>>
<<SF isr: public test>>
contains
<<SF isr: test driver>>
end module sf_isr_ut
@ %def sf_isr_ut
@
<<[[sf_isr_uti.f90]]>>=
<<File header>>
module sf_isr_uti
<<Use kinds>>
<<Use strings>>
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
<<Standard module head>>
<<SF isr: test declarations>>
contains
<<SF isr: tests>>
end module sf_isr_uti
@ %def sf_isr_ut
@ API: driver for the unit tests below.
<<SF isr: public test>>=
public :: sf_isr_test
<<SF isr: test driver>>=
subroutine sf_isr_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF isr: execute tests>>
end subroutine sf_isr_test
@ %def sf_isr_test
@
\subsubsection{Test structure function data}
Construct and display a test structure function data object.
<<SF isr: execute tests>>=
call test (sf_isr_1, "sf_isr_1", &
"structure function configuration", &
u, results)
<<SF isr: test declarations>>=
public :: sf_isr_1
<<SF isr: tests>>=
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.
<<SF isr: execute tests>>=
call test (sf_isr_2, "sf_isr_2", &
"no ISR mapping", &
u, results)
<<SF isr: test declarations>>=
public :: sf_isr_2
<<SF isr: tests>>=
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.
<<SF isr: execute tests>>=
call test (sf_isr_3, "sf_isr_3", &
"ISR mapping", &
u, results)
<<SF isr: test declarations>>=
public :: sf_isr_3
<<SF isr: tests>>=
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.
<<SF isr: execute tests>>=
call test (sf_isr_4, "sf_isr_4", &
"ISR non-collinear", &
u, results)
<<SF isr: test declarations>>=
public :: sf_isr_4
<<SF isr: tests>>=
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.
<<SF isr: execute tests>>=
call test (sf_isr_5, "sf_isr_5", &
"ISR pair mapping", &
u, results)
<<SF isr: test declarations>>=
public :: sf_isr_5
<<SF isr: tests>>=
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]]>>=
<<File header>>
module sf_epa
<<Use kinds>>
<<Use strings>>
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
<<Standard module head>>
<<SF epa: public>>
<<SF epa: parameters>>
<<SF epa: types>>
interface
<<SF epa: sub interfaces>>
end interface
contains
<<SF epa: main procedures>>
end module sf_epa
@ %def sf_epa
@
<<[[sf_epa_sub.f90]]>>=
<<File header>>
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
<<SF epa: procedures>>
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.
<<SF epa: public>>=
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
<<SF epa: parameters>>=
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
@
<<SF epa: public>>=
public :: epa_data_t
<<SF epa: types>>=
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
<<SF epa: epa data: TBP>>
end type epa_data_t
@ %def epa_data_t
@ Error codes
<<SF epa: parameters>>=
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
<<SF epa: epa data: TBP>>=
procedure :: init => epa_data_init
<<SF epa: sub interfaces>>=
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
<<SF epa: procedures>>=
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.
<<SF epa: epa data: TBP>>=
procedure :: check => epa_data_check
<<SF epa: sub interfaces>>=
module subroutine epa_data_check (data)
class(epa_data_t), intent(in) :: data
end subroutine epa_data_check
<<SF epa: procedures>>=
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
<<SF epa: epa data: TBP>>=
procedure :: write => epa_data_write
<<SF epa: sub interfaces>>=
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
<<SF epa: procedures>>=
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.
<<SF epa: epa data: TBP>>=
procedure :: get_n_par => epa_data_get_n_par
<<SF epa: sub interfaces>>=
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
<<SF epa: procedures>>=
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.
<<SF epa: epa data: TBP>>=
procedure :: get_pdg_out => epa_data_get_pdg_out
<<SF epa: sub interfaces>>=
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
<<SF epa: procedures>>=
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.
<<SF epa: epa data: TBP>>=
procedure :: allocate_sf_int => epa_data_allocate_sf_int
<<SF epa: main procedures>>=
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.
<<SF epa: types>>=
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
<<SF epa: epa: TBP>>
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.
<<SF epa: epa: TBP>>=
procedure :: type_string => epa_type_string
<<SF epa: sub interfaces>>=
module function epa_type_string (object) result (string)
class(epa_t), intent(in) :: object
type(string_t) :: string
end function epa_type_string
<<SF epa: procedures>>=
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.
<<SF epa: epa: TBP>>=
procedure :: write => epa_write
<<SF epa: sub interfaces>>=
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
<<SF epa: procedures>>=
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.
<<SF epa: epa: TBP>>=
procedure :: init => epa_init
<<SF epa: sub interfaces>>=
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
<<SF epa: procedures>>=
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.
<<SF epa: epa: TBP>>=
procedure :: setup_constants => epa_setup_constants
<<SF epa: sub interfaces>>=
module subroutine epa_setup_constants (sf_int)
class(epa_t), intent(inout), target :: sf_int
end subroutine epa_setup_constants
<<SF epa: procedures>>=
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$.
<<SF epa: epa: TBP>>=
procedure :: complete_kinematics => epa_complete_kinematics
<<SF epa: sub interfaces>>=
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
<<SF epa: procedures>>=
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.
<<SF epa: epa: TBP>>=
procedure :: recover_x => sf_epa_recover_x
<<SF epa: sub interfaces>>=
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
<<SF epa: procedures>>=
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.
<<SF epa: epa: TBP>>=
procedure :: inverse_kinematics => epa_inverse_kinematics
<<SF epa: sub interfaces>>=
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
<<SF epa: procedures>>=
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.
<<SF epa: epa: TBP>>=
procedure :: apply => epa_apply
<<SF epa: sub interfaces>>=
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
<<SF epa: procedures>>=
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]]>>=
<<File header>>
module sf_epa_ut
use unit_tests
use sf_epa_uti
<<Standard module head>>
<<SF epa: public test>>
contains
<<SF epa: test driver>>
end module sf_epa_ut
@ %def sf_epa_ut
@
<<[[sf_epa_uti.f90]]>>=
<<File header>>
module sf_epa_uti
<<Use kinds>>
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
<<Standard module head>>
<<SF epa: test declarations>>
contains
<<SF epa: tests>>
end module sf_epa_uti
@ %def sf_epa_ut
@ API: driver for the unit tests below.
<<SF epa: public test>>=
public :: sf_epa_test
<<SF epa: test driver>>=
subroutine sf_epa_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF epa: execute tests>>
end subroutine sf_epa_test
@ %def sf_epa_test
@
\subsubsection{Test structure function data}
Construct and display a test structure function data object.
<<SF epa: execute tests>>=
call test (sf_epa_1, "sf_epa_1", &
"structure function configuration", &
u, results)
<<SF epa: test declarations>>=
public :: sf_epa_1
<<SF epa: tests>>=
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.
<<SF epa: execute tests>>=
call test (sf_epa_2, "sf_epa_2", &
"structure function instance", &
u, results)
<<SF epa: test declarations>>=
public :: sf_epa_2
<<SF epa: tests>>=
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.
<<SF epa: execute tests>>=
call test (sf_epa_3, "sf_epa_3", &
"apply mapping", &
u, results)
<<SF epa: test declarations>>=
public :: sf_epa_3
<<SF epa: tests>>=
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.
<<SF epa: execute tests>>=
call test (sf_epa_4, "sf_epa_4", &
"non-collinear", &
u, results)
<<SF epa: test declarations>>=
public :: sf_epa_4
<<SF epa: tests>>=
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.
<<SF epa: execute tests>>=
call test (sf_epa_5, "sf_epa_5", &
"multiple flavors", &
u, results)
<<SF epa: test declarations>>=
public :: sf_epa_5
<<SF epa: tests>>=
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]]>>=
<<File header>>
module sf_ewa
<<Use kinds>>
<<Use strings>>
use pdg_arrays
use model_data
use flavors
use quantum_numbers
use state_matrices
use polarizations
use interactions
use sf_aux
use sf_base
<<Standard module head>>
<<SF ewa: public>>
<<SF ewa: parameters>>
<<SF ewa: types>>
interface
<<SF ewa: sub interfaces>>
end interface
contains
<<SF ewa: main procedures>>
end module sf_ewa
@ %def sf_ewa
@
<<[[sf_ewa_sub.f90]]>>=
<<File header>>
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
<<SF ewa: procedures>>
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.
<<SF ewa: public>>=
public :: ewa_data_t
<<SF ewa: types>>=
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
<<SF ewa: ewa data: TBP>>
end type ewa_data_t
@ %def ewa_data_t
@ Error codes
<<SF ewa: parameters>>=
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
<<SF ewa: ewa data: TBP>>=
procedure :: init => ewa_data_init
<<SF ewa: sub interfaces>>=
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
<<SF ewa: procedures>>=
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.
<<SF ewa: ewa data: TBP>>=
procedure :: set_id => ewa_set_id
<<SF ewa: sub interfaces>>=
module subroutine ewa_set_id (data, id)
class(ewa_data_t), intent(inout) :: data
integer, intent(in) :: id
end subroutine ewa_set_id
<<SF ewa: procedures>>=
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.
<<SF ewa: ewa data: TBP>>=
procedure :: check => ewa_data_check
<<SF ewa: sub interfaces>>=
module subroutine ewa_data_check (data)
class(ewa_data_t), intent(in) :: data
end subroutine ewa_data_check
<<SF ewa: procedures>>=
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
<<SF ewa: ewa data: TBP>>=
procedure :: write => ewa_data_write
<<SF ewa: sub interfaces>>=
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
<<SF ewa: procedures>>=
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.
<<SF ewa: ewa data: TBP>>=
procedure :: get_n_par => ewa_data_get_n_par
<<SF ewa: sub interfaces>>=
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
<<SF ewa: procedures>>=
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.
<<SF ewa: ewa data: TBP>>=
procedure :: get_pdg_out => ewa_data_get_pdg_out
<<SF ewa: sub interfaces>>=
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
<<SF ewa: procedures>>=
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.
<<SF ewa: ewa data: TBP>>=
procedure :: allocate_sf_int => ewa_data_allocate_sf_int
<<SF ewa: main procedures>>=
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.
<<SF ewa: types>>=
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
<<SF ewa: ewa: TBP>>
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.
<<SF ewa: ewa: TBP>>=
procedure :: type_string => ewa_type_string
<<SF ewa: sub interfaces>>=
module function ewa_type_string (object) result (string)
class(ewa_t), intent(in) :: object
type(string_t) :: string
end function ewa_type_string
<<SF ewa: procedures>>=
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.
<<SF ewa: ewa: TBP>>=
procedure :: write => ewa_write
<<SF ewa: sub interfaces>>=
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
<<SF ewa: procedures>>=
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.
<<SF ewa: ewa: TBP>>=
procedure :: init => ewa_init
<<SF ewa: sub interfaces>>=
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
<<SF ewa: procedures>>=
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.
<<SF ewa: ewa: TBP>>=
procedure :: setup_constants => ewa_setup_constants
<<SF ewa: sub interfaces>>=
module subroutine ewa_setup_constants (sf_int)
class(ewa_t), intent(inout), target :: sf_int
end subroutine ewa_setup_constants
<<SF ewa: procedures>>=
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.
<<SF ewa: ewa: TBP>>=
procedure :: complete_kinematics => ewa_complete_kinematics
<<SF ewa: sub interfaces>>=
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
<<SF ewa: procedures>>=
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.
<<SF ewa: ewa: TBP>>=
procedure :: recover_x => sf_ewa_recover_x
<<SF ewa: sub interfaces>>=
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
<<SF ewa: procedures>>=
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.
<<SF ewa: ewa: TBP>>=
procedure :: inverse_kinematics => ewa_inverse_kinematics
<<SF ewa: sub interfaces>>=
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
<<SF ewa: procedures>>=
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.
<<SF ewa: ewa: TBP>>=
procedure :: apply => ewa_apply
<<SF ewa: sub interfaces>>=
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
<<SF ewa: procedures>>=
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]]>>=
<<File header>>
module sf_ewa_ut
use unit_tests
use sf_ewa_uti
<<Standard module head>>
<<SF ewa: public test>>
contains
<<SF ewa: test driver>>
end module sf_ewa_ut
@ %def sf_ewa_ut
@
<<[[sf_ewa_uti.f90]]>>=
<<File header>>
module sf_ewa_uti
<<Use kinds>>
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
<<Standard module head>>
<<SF ewa: test declarations>>
contains
<<SF ewa: tests>>
end module sf_ewa_uti
@ %def sf_ewa_ut
@ API: driver for the unit tests below.
<<SF ewa: public test>>=
public :: sf_ewa_test
<<SF ewa: test driver>>=
subroutine sf_ewa_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF ewa: execute tests>>
end subroutine sf_ewa_test
@ %def sf_ewa_test
@
\subsubsection{Test structure function data}
Construct and display a test structure function data object.
<<SF ewa: execute tests>>=
call test (sf_ewa_1, "sf_ewa_1", &
"structure function configuration", &
u, results)
<<SF ewa: test declarations>>=
public :: sf_ewa_1
<<SF ewa: tests>>=
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.
<<SF ewa: execute tests>>=
call test (sf_ewa_2, "sf_ewa_2", &
"structure function instance", &
u, results)
<<SF ewa: test declarations>>=
public :: sf_ewa_2
<<SF ewa: tests>>=
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.
<<SF ewa: execute tests>>=
call test (sf_ewa_3, "sf_ewa_3", &
"apply mapping", &
u, results)
<<SF ewa: test declarations>>=
public :: sf_ewa_3
<<SF ewa: tests>>=
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.
<<SF ewa: execute tests>>=
call test (sf_ewa_4, "sf_ewa_4", &
"non-collinear", &
u, results)
<<SF ewa: test declarations>>=
public :: sf_ewa_4
<<SF ewa: tests>>=
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.
<<SF ewa: execute tests>>=
call test (sf_ewa_5, "sf_ewa_5", &
"structure function instance", &
u, results)
<<SF ewa: test declarations>>=
public :: sf_ewa_5
<<SF ewa: tests>>=
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]]>>=
<<File header>>
module sf_escan
<<Use kinds>>
<<Use strings>>
use pdg_arrays
use model_data
use flavors
use quantum_numbers
use state_matrices
use polarizations
use sf_base
<<Standard module head>>
<<SF escan: public>>
<<SF escan: types>>
interface
<<SF escan: sub interfaces>>
end interface
contains
<<SF escan: main procedures>>
end module sf_escan
@ %def sf_escan
@
<<[[sf_escan_sub.f90]]>>=
<<File header>>
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
<<SF escan: procedures>>
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}$.
<<SF escan: public>>=
public :: escan_data_t
<<SF escan: types>>=
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
<<SF escan: escan data: TBP>>
end type escan_data_t
@ %def escan_data_t
<<SF escan: escan data: TBP>>=
procedure :: init => escan_data_init
<<SF escan: sub interfaces>>=
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
<<SF escan: procedures>>=
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
<<SF escan: escan data: TBP>>=
procedure :: write => escan_data_write
<<SF escan: sub interfaces>>=
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
<<SF escan: procedures>>=
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.
<<SF escan: escan data: TBP>>=
procedure :: get_n_par => escan_data_get_n_par
<<SF escan: sub interfaces>>=
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
<<SF escan: procedures>>=
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.
<<SF escan: escan data: TBP>>=
procedure :: get_pdg_out => escan_data_get_pdg_out
<<SF escan: sub interfaces>>=
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
<<SF escan: procedures>>=
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.
<<SF escan: escan data: TBP>>=
procedure :: allocate_sf_int => escan_data_allocate_sf_int
<<SF escan: main procedures>>=
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.
<<SF escan: types>>=
type, extends (sf_int_t) :: escan_t
type(escan_data_t), pointer :: data => null ()
contains
<<SF escan: escan: TBP>>
end type escan_t
@ %def escan_t
@ Type string: for the energy scan this is just a dummy function.
<<SF escan: escan: TBP>>=
procedure :: type_string => escan_type_string
<<SF escan: sub interfaces>>=
module function escan_type_string (object) result (string)
class(escan_t), intent(in) :: object
type(string_t) :: string
end function escan_type_string
<<SF escan: procedures>>=
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.
<<SF escan: escan: TBP>>=
procedure :: write => escan_write
<<SF escan: sub interfaces>>=
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
<<SF escan: procedures>>=
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
@
<<SF escan: escan: TBP>>=
procedure :: init => escan_init
<<SF escan: sub interfaces>>=
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
<<SF escan: procedures>>=
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.
<<SF escan: escan: TBP>>=
procedure :: complete_kinematics => escan_complete_kinematics
<<SF escan: sub interfaces>>=
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
<<SF escan: procedures>>=
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.
<<SF escan: escan: TBP>>=
procedure :: recover_x => escan_recover_x
<<SF escan: sub interfaces>>=
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
<<SF escan: procedures>>=
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.
<<SF escan: escan: TBP>>=
procedure :: inverse_kinematics => escan_inverse_kinematics
<<SF escan: sub interfaces>>=
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
<<SF escan: procedures>>=
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.
<<SF escan: escan: TBP>>=
procedure :: apply => escan_apply
<<SF escan: sub interfaces>>=
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
<<SF escan: procedures>>=
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]]>>=
<<File header>>
module sf_escan_ut
use unit_tests
use sf_escan_uti
<<Standard module head>>
<<SF escan: public test>>
contains
<<SF escan: test driver>>
end module sf_escan_ut
@ %def sf_escan_ut
@
<<[[sf_escan_uti.f90]]>>=
<<File header>>
module sf_escan_uti
<<Use kinds>>
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
<<Standard module head>>
<<SF escan: test declarations>>
contains
<<SF escan: tests>>
end module sf_escan_uti
@ %def sf_escan_ut
@ API: driver for the unit tests below.
<<SF escan: public test>>=
public :: sf_escan_test
<<SF escan: test driver>>=
subroutine sf_escan_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF escan: execute tests>>
end subroutine sf_escan_test
@ %def sf_escan_test
@
\subsubsection{Test structure function data}
Construct and display a test structure function data object.
<<SF escan: execute tests>>=
call test (sf_escan_1, "sf_escan_1", &
"structure function configuration", &
u, results)
<<SF escan: test declarations>>=
public :: sf_escan_1
<<SF escan: tests>>=
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.
<<SF escan: execute tests>>=
call test (sf_escan_2, "sf_escan_2", &
"generate event", &
u, results)
<<SF escan: test declarations>>=
public :: sf_escan_2
<<SF escan: tests>>=
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]]>>=
<<File header>>
module sf_gaussian
<<Use kinds>>
<<Use strings>>
use rng_base
use pdg_arrays
use model_data
use flavors
use quantum_numbers
use state_matrices
use polarizations
use sf_base
<<Standard module head>>
<<SF gaussian: public>>
<<SF gaussian: types>>
interface
<<SF gaussian: sub interfaces>>
end interface
contains
<<SF gaussian: main procedures>>
end module sf_gaussian
@ %def sf_gaussian
@
<<[[sf_gaussian_sub.f90]]>>=
<<File header>>
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
<<SF gaussian: procedures>>
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.
<<CCC SF gaussian: variables>>=
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.
<<SF gaussian: public>>=
public :: gaussian_data_t
<<SF gaussian: types>>=
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
<<SF gaussian: gaussian data: TBP>>
end type gaussian_data_t
@ %def gaussian_data_t
<<SF gaussian: gaussian data: TBP>>=
procedure :: init => gaussian_data_init
<<SF gaussian: sub interfaces>>=
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
<<SF gaussian: procedures>>=
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.
<<SF gaussian: gaussian data: TBP>>=
procedure :: is_generator => gaussian_data_is_generator
<<SF gaussian: sub interfaces>>=
module function gaussian_data_is_generator (data) result (flag)
class(gaussian_data_t), intent(in) :: data
logical :: flag
end function gaussian_data_is_generator
<<SF gaussian: procedures>>=
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.
<<SF gaussian: gaussian data: TBP>>=
procedure :: get_n_par => gaussian_data_get_n_par
<<SF gaussian: sub interfaces>>=
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
<<SF gaussian: procedures>>=
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
<<SF gaussian: gaussian data: TBP>>=
procedure :: get_pdg_out => gaussian_data_get_pdg_out
<<SF gaussian: sub interfaces>>=
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
<<SF gaussian: procedures>>=
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.
<<SF gaussian: gaussian data: TBP>>=
procedure :: allocate_sf_int => gaussian_data_allocate_sf_int
<<SF gaussian: main procedures>>=
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
<<SF gaussian: gaussian data: TBP>>=
procedure :: write => gaussian_data_write
<<SF gaussian: sub interfaces>>=
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
<<SF gaussian: procedures>>=
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.
<<SF gaussian: public>>=
public :: gaussian_t
<<SF gaussian: types>>=
type, extends (sf_int_t) :: gaussian_t
type(gaussian_data_t), pointer :: data => null ()
class(rng_t), allocatable :: rng
contains
<<SF gaussian: gaussian: TBP>>
end type gaussian_t
@ %def gaussian_t
@ Type string: show gaussian file.
<<SF gaussian: gaussian: TBP>>=
procedure :: type_string => gaussian_type_string
<<SF gaussian: sub interfaces>>=
module function gaussian_type_string (object) result (string)
class(gaussian_t), intent(in) :: object
type(string_t) :: string
end function gaussian_type_string
<<SF gaussian: procedures>>=
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.
<<SF gaussian: gaussian: TBP>>=
procedure :: write => gaussian_write
<<SF gaussian: sub interfaces>>=
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
<<SF gaussian: procedures>>=
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
@
<<SF gaussian: gaussian: TBP>>=
procedure :: init => gaussian_init
<<SF gaussian: sub interfaces>>=
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
<<SF gaussian: procedures>>=
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.
<<SF gaussian: gaussian: TBP>>=
procedure :: final => sf_gaussian_final
<<SF gaussian: sub interfaces>>=
module subroutine sf_gaussian_final (object)
class(gaussian_t), intent(inout) :: object
end subroutine sf_gaussian_final
<<SF gaussian: procedures>>=
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.
<<SF gaussian: gaussian: TBP>>=
procedure :: is_generator => gaussian_is_generator
<<SF gaussian: sub interfaces>>=
module function gaussian_is_generator (sf_int) result (flag)
class(gaussian_t), intent(in) :: sf_int
logical :: flag
end function gaussian_is_generator
<<SF gaussian: procedures>>=
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.
<<SF gaussian: gaussian: TBP>>=
procedure :: generate_free => gaussian_generate_free
<<SF gaussian: sub interfaces>>=
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
<<SF gaussian: procedures>>=
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.
<<SF gaussian: gaussian: TBP>>=
procedure :: complete_kinematics => gaussian_complete_kinematics
<<SF gaussian: sub interfaces>>=
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
<<SF gaussian: procedures>>=
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.
<<SF gaussian: gaussian: TBP>>=
procedure :: inverse_kinematics => gaussian_inverse_kinematics
<<SF gaussian: sub interfaces>>=
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
<<SF gaussian: procedures>>=
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.
<<SF gaussian: gaussian: TBP>>=
procedure :: apply => gaussian_apply
<<SF gaussian: sub interfaces>>=
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
<<SF gaussian: procedures>>=
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]]>>=
<<File header>>
module sf_gaussian_ut
use unit_tests
use sf_gaussian_uti
<<Standard module head>>
<<SF gaussian: public test>>
contains
<<SF gaussian: test driver>>
end module sf_gaussian_ut
@ %def sf_gaussian_ut
@
<<[[sf_gaussian_uti.f90]]>>=
<<File header>>
module sf_gaussian_uti
<<Use kinds>>
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
<<Standard module head>>
<<SF gaussian: test declarations>>
contains
<<SF gaussian: tests>>
end module sf_gaussian_uti
@ %def sf_gaussian_ut
@ API: driver for the unit tests below.
<<SF gaussian: public test>>=
public :: sf_gaussian_test
<<SF gaussian: test driver>>=
subroutine sf_gaussian_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF gaussian: execute tests>>
end subroutine sf_gaussian_test
@ %def sf_gaussian_test
@
\subsubsection{Test structure function data}
Construct and display a test structure function data object.
<<SF gaussian: execute tests>>=
call test (sf_gaussian_1, "sf_gaussian_1", &
"structure function configuration", &
u, results)
<<SF gaussian: test declarations>>=
public :: sf_gaussian_1
<<SF gaussian: tests>>=
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.
<<SF gaussian: execute tests>>=
call test (sf_gaussian_2, "sf_gaussian_2", &
"generate event", &
u, results)
<<SF gaussian: test declarations>>=
public :: sf_gaussian_2
<<SF gaussian: tests>>=
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]]>>=
<<File header>>
module sf_beam_events
<<Use kinds>>
<<Use strings>>
use file_registries
use pdg_arrays
use model_data
use flavors
use quantum_numbers
use state_matrices
use polarizations
use sf_base
<<Standard module head>>
<<SF beam events: public>>
<<SF beam events: types>>
<<SF beam events: variables>>
interface
<<SF beam events: sub interfaces>>
end interface
contains
<<SF beam events: main procedures>>
end module sf_beam_events
@ %def sf_beam_events
@
<<[[sf_beam_events_sub.f90]]>>=
<<File header>>
submodule (sf_beam_events) sf_beam_events_s
use io_units
use diagnostics
use lorentz
implicit none
contains
<<SF beam events: procedures>>
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.
<<SF beam events: public>>=
public :: beam_file_registry
<<SF beam events: variables>>=
type(file_registry_t), save :: beam_file_registry
@ %def beam_file_registry
@
\subsection{Data type}
<<SF beam events: public>>=
public :: beam_events_data_t
<<SF beam events: types>>=
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
<<SF beam events: beam events data: TBP>>
end type beam_events_data_t
@ %def beam_events_data_t
<<SF beam events: beam events data: TBP>>=
procedure :: init => beam_events_data_init
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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.
<<SF beam events: beam events data: TBP>>=
procedure :: is_generator => beam_events_data_is_generator
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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.
<<SF beam events: beam events data: TBP>>=
procedure :: get_n_par => beam_events_data_get_n_par
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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
<<SF beam events: beam events data: TBP>>=
procedure :: get_pdg_out => beam_events_data_get_pdg_out
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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.
<<SF beam events: beam events data: TBP>>=
procedure :: allocate_sf_int => beam_events_data_allocate_sf_int
<<SF beam events: main procedures>>=
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
<<SF beam events: beam events data: TBP>>=
procedure :: write => beam_events_data_write
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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.
<<SF beam events: beam events data: TBP>>=
procedure :: open => beam_events_data_open
procedure :: close => beam_events_data_close
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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.
<<SF beam events: beam events data: TBP>>=
procedure :: get_beam_file => beam_events_data_get_beam_file
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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.
<<SF beam events: public>>=
public :: beam_events_t
<<SF beam events: types>>=
type, extends (sf_int_t) :: beam_events_t
type(beam_events_data_t), pointer :: data => null ()
integer :: count = 0
contains
<<SF beam events: beam events: TBP>>
end type beam_events_t
@ %def beam_events_t
@ Type string: show beam events file.
<<SF beam events: beam events: TBP>>=
procedure :: type_string => beam_events_type_string
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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.
<<SF beam events: beam events: TBP>>=
procedure :: write => beam_events_write
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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
@
<<SF beam events: beam events: TBP>>=
procedure :: init => beam_events_init
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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.
<<SF beam events: beam events: TBP>>=
procedure :: final => sf_beam_events_final
<<SF beam events: sub interfaces>>=
module subroutine sf_beam_events_final (object)
class(beam_events_t), intent(inout) :: object
end subroutine sf_beam_events_final
<<SF beam events: procedures>>=
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.
<<SF beam events: beam events: TBP>>=
procedure :: is_generator => beam_events_is_generator
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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.
<<SF beam events: beam events: TBP>>=
procedure :: generate_free => beam_events_generate_free
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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.
<<SF beam events: beam events: TBP>>=
procedure :: complete_kinematics => beam_events_complete_kinematics
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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.
<<SF beam events: beam events: TBP>>=
procedure :: inverse_kinematics => beam_events_inverse_kinematics
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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.
<<SF beam events: beam events: TBP>>=
procedure :: apply => beam_events_apply
<<SF beam events: sub interfaces>>=
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
<<SF beam events: procedures>>=
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]]>>=
<<File header>>
module sf_beam_events_ut
use unit_tests
use sf_beam_events_uti
<<Standard module head>>
<<SF beam events: public test>>
contains
<<SF beam events: test driver>>
end module sf_beam_events_ut
@ %def sf_beam_events_ut
@
<<[[sf_beam_events_uti.f90]]>>=
<<File header>>
module sf_beam_events_uti
<<Use kinds>>
<<Use strings>>
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
<<Standard module head>>
<<SF beam events: test declarations>>
contains
<<SF beam events: tests>>
end module sf_beam_events_uti
@ %def sf_beam_events_ut
@ API: driver for the unit tests below.
<<SF beam events: public test>>=
public :: sf_beam_events_test
<<SF beam events: test driver>>=
subroutine sf_beam_events_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF beam events: execute tests>>
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.
<<SF beam events: execute tests>>=
call test (sf_beam_events_1, "sf_beam_events_1", &
"structure function configuration", &
u, results)
<<SF beam events: test declarations>>=
public :: sf_beam_events_1
<<SF beam events: tests>>=
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.
<<SF beam events: execute tests>>=
call test (sf_beam_events_2, "sf_beam_events_2", &
"generate event", &
u, results)
<<SF beam events: test declarations>>=
public :: sf_beam_events_2
<<SF beam events: tests>>=
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.
<<SF beam events: execute tests>>=
call test (sf_beam_events_3, "sf_beam_events_3", &
"check registry", &
u, results)
<<SF beam events: test declarations>>=
public :: sf_beam_events_3
<<SF beam events: tests>>=
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]]>>=
<<File header>>
module sf_circe1
<<Use kinds>>
use kinds, only: double
<<Use strings>>
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!
<<Standard module head>>
<<SF circe1: public>>
<<SF circe1: types>>
interface
<<SF circe1: sub interfaces>>
end interface
contains
<<SF circe1: main procedures>>
end module sf_circe1
@ %def sf_circe1
@
<<[[sf_circe1_sub.f90]]>>=
<<File header>>
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
<<SF circe1: procedures>>
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.
<<SF circe1: public>>=
public :: circe1_data_t
<<SF circe1: types>>=
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
<<SF circe1: circe1 data: TBP>>
end type circe1_data_t
@ %def circe1_data_t
@
<<SF circe1: circe1 data: TBP>>=
procedure :: init => circe1_data_init
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1 data: TBP>>=
procedure :: set_generator_mode => circe1_data_set_generator_mode
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1 data: TBP>>=
procedure :: check => circe1_data_check
<<SF circe1: sub interfaces>>=
module subroutine circe1_data_check (data)
class(circe1_data_t), intent(in) :: data
end subroutine circe1_data_check
<<SF circe1: procedures>>=
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
<<SF circe1: circe1 data: TBP>>=
procedure :: write => circe1_data_write
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1 data: TBP>>=
procedure :: is_generator => circe1_data_is_generator
<<SF circe1: sub interfaces>>=
module function circe1_data_is_generator (data) result (flag)
class(circe1_data_t), intent(in) :: data
logical :: flag
end function circe1_data_is_generator
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1 data: TBP>>=
procedure :: get_n_par => circe1_data_get_n_par
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1 data: TBP>>=
procedure :: get_pdg_out => circe1_data_get_pdg_out
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1 data: TBP>>=
procedure :: get_pdg_int => circe1_data_get_pdg_int
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1 data: TBP>>=
procedure :: allocate_sf_int => circe1_data_allocate_sf_int
<<SF circe1: main procedures>>=
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.
<<SF circe1: circe1 data: TBP>>=
procedure :: get_beam_file => circe1_data_get_beam_file
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: types>>=
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
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: public>>=
public :: circe1_t
<<SF circe1: types>>=
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
<<SF circe1: circe1: TBP>>
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.
<<SF circe1: circe1: TBP>>=
procedure :: type_string => circe1_type_string
<<SF circe1: sub interfaces>>=
module function circe1_type_string (object) result (string)
class(circe1_t), intent(in) :: object
type(string_t) :: string
end function circe1_type_string
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1: TBP>>=
procedure :: write => circe1_write
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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
@
<<SF circe1: circe1: TBP>>=
procedure :: init => circe1_init
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1: TBP>>=
procedure :: is_generator => circe1_is_generator
<<SF circe1: sub interfaces>>=
module function circe1_is_generator (sf_int) result (flag)
class(circe1_t), intent(in) :: sf_int
logical :: flag
end function circe1_is_generator
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1: TBP>>=
procedure :: generate_free => circe1_generate_free
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1: TBP>>=
procedure :: complete_kinematics => circe1_complete_kinematics
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1: TBP>>=
procedure :: inverse_kinematics => circe1_inverse_kinematics
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: circe1: TBP>>=
procedure :: apply => circe1_apply
<<SF circe1: sub interfaces>>=
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
<<SF circe1: procedures>>=
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.
<<SF circe1: procedures>>=
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]]>>=
<<File header>>
module sf_circe1_ut
use unit_tests
use sf_circe1_uti
<<Standard module head>>
<<SF circe1: public test>>
contains
<<SF circe1: test driver>>
end module sf_circe1_ut
@ %def sf_circe1_ut
@
<<[[sf_circe1_uti.f90]]>>=
<<File header>>
module sf_circe1_uti
<<Use kinds>>
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
<<Standard module head>>
<<SF circe1: test declarations>>
contains
<<SF circe1: tests>>
end module sf_circe1_uti
@ %def sf_circe1_ut
@ API: driver for the unit tests below.
<<SF circe1: public test>>=
public :: sf_circe1_test
<<SF circe1: test driver>>=
subroutine sf_circe1_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF circe1: execute tests>>
end subroutine sf_circe1_test
@ %def sf_circe1_test
@
\subsubsection{Test structure function data}
Construct and display a test structure function data object.
<<SF circe1: execute tests>>=
call test (sf_circe1_1, "sf_circe1_1", &
"structure function configuration", &
u, results)
<<SF circe1: test declarations>>=
public :: sf_circe1_1
<<SF circe1: tests>>=
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.
<<SF circe1: execute tests>>=
call test (sf_circe1_2, "sf_circe1_2", &
"structure function instance", &
u, results)
<<SF circe1: test declarations>>=
public :: sf_circe1_2
<<SF circe1: tests>>=
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.
<<SF circe1: execute tests>>=
call test (sf_circe1_3, "sf_circe1_3", &
"generator mode", &
u, results)
<<SF circe1: test declarations>>=
public :: sf_circe1_3
<<SF circe1: tests>>=
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]]>>=
<<File header>>
module sf_circe2
<<Use kinds>>
<<Use strings>>
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!
<<Standard module head>>
<<SF circe2: public>>
<<SF circe2: types>>
interface
<<SF circe2: sub interfaces>>
end interface
contains
<<SF circe2: main procedures>>
end module sf_circe2
@ %def sf_circe2
@
<<[[sf_circe2_sub.f90]]>>=
<<File header>>
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, MUON
use lorentz
use colors
use helicities
use quantum_numbers
use state_matrices
implicit none
contains
<<SF circe2: procedures>>
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]].
<<SF circe2: public>>=
public :: circe2_data_t
<<SF circe2: types>>=
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
<<SF circe2: circe2 data: TBP>>
end type circe2_data_t
@ %def circe2_data_t
<<SF circe2: types>>=
type(circe2_state) :: circe2_global_state
@
<<SF circe2: circe2 data: TBP>>=
procedure :: init => circe2_data_init
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2 data: TBP>>=
procedure :: set_generator_mode => circe2_data_set_generator_mode
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2 data: TBP>>=
procedure :: check_file => circe2_check_file
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2 data: TBP>>=
procedure :: check => circe2_data_check
<<SF circe2: sub interfaces>>=
module subroutine circe2_data_check (data)
class(circe2_data_t), intent(in) :: data
end subroutine circe2_data_check
<<SF circe2: procedures>>=
module subroutine circe2_data_check (data)
class(circe2_data_t), intent(in) :: data
type(flavor_t) :: flv_photon, flv_electron, flv_muon
call flv_photon%init (PHOTON, data%model)
if (.not. flv_photon%is_defined ()) then
call msg_fatal ("CIRCE2: model must contain photon")
end if
if (any (abs (data%pdg_in) /= PHOTON .and. abs (data%pdg_in) /= &
ELECTRON .and. abs (data%pdg_in) /= MUON)) then
call msg_fatal ("CIRCE2: applicable only for e+e-, mu+mu- or " // &
"photon collisions")
end if
if (any (abs (data%pdg_in) == ELECTRON)) then
call flv_electron%init (ELECTRON, data%model)
if (.not. flv_electron%is_defined ()) then
call msg_fatal ("CIRCE2: model must contain electron")
end if
end if
if (any (abs (data%pdg_in) == MUON)) then
call flv_muon%init (MUON, data%model)
if (.not. flv_muon%is_defined ()) then
call msg_fatal ("CIRCE2: model must contain muon")
end if
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
<<SF circe2: circe2 data: TBP>>=
procedure :: write => circe2_data_write
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2 data: TBP>>=
procedure :: is_generator => circe2_data_is_generator
<<SF circe2: sub interfaces>>=
module function circe2_data_is_generator (data) result (flag)
class(circe2_data_t), intent(in) :: data
logical :: flag
end function circe2_data_is_generator
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2 data: TBP>>=
procedure :: get_n_par => circe2_data_get_n_par
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2 data: TBP>>=
procedure :: get_pdg_out => circe2_data_get_pdg_out
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2 data: TBP>>=
procedure :: allocate_sf_int => circe2_data_allocate_sf_int
<<SF circe2: main procedures>>=
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.
<<SF circe2: circe2 data: TBP>>=
procedure :: get_beam_file => circe2_data_get_beam_file
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.
<<SF circe2: types>>=
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
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.
<<SF circe2: public>>=
public :: circe2_t
<<SF circe2: types>>=
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
<<SF circe2: circe2: TBP>>
end type circe2_t
@ %def circe2_t
@ Type string: show file and design of [[CIRCE2]] structure function.
<<SF circe2: circe2: TBP>>=
procedure :: type_string => circe2_type_string
<<SF circe2: sub interfaces>>=
module function circe2_type_string (object) result (string)
class(circe2_t), intent(in) :: object
type(string_t) :: string
end function circe2_type_string
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2: TBP>>=
procedure :: write => circe2_write
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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
@
<<SF circe2: circe2: TBP>>=
procedure :: init => circe2_init
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2: TBP>>=
procedure :: is_generator => circe2_is_generator
<<SF circe2: sub interfaces>>=
module function circe2_is_generator (sf_int) result (flag)
class(circe2_t), intent(in) :: sf_int
logical :: flag
end function circe2_is_generator
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2: TBP>>=
procedure :: generate_free => circe2_generate_whizard_free
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.)
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2: TBP>>=
procedure :: complete_kinematics => circe2_complete_kinematics
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2: TBP>>=
procedure :: inverse_kinematics => circe2_inverse_kinematics
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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.
<<SF circe2: circe2: TBP>>=
procedure :: apply => circe2_apply
<<SF circe2: sub interfaces>>=
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
<<SF circe2: procedures>>=
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]]>>=
<<File header>>
module sf_circe2_ut
use unit_tests
use sf_circe2_uti
<<Standard module head>>
<<SF circe2: public test>>
contains
<<SF circe2: test driver>>
end module sf_circe2_ut
@ %def sf_circe2_ut
@
<<[[sf_circe2_uti.f90]]>>=
<<File header>>
module sf_circe2_uti
<<Use kinds>>
<<Use strings>>
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
<<Standard module head>>
<<SF circe2: test declarations>>
contains
<<SF circe2: tests>>
end module sf_circe2_uti
@ %def sf_circe2_ut
@ API: driver for the unit tests below.
<<SF circe2: public test>>=
public :: sf_circe2_test
<<SF circe2: test driver>>=
subroutine sf_circe2_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF circe2: execute tests>>
end subroutine sf_circe2_test
@ %def sf_circe2_test
@
\subsubsection{Test structure function data}
Construct and display a test structure function data object.
<<SF circe2: execute tests>>=
call test (sf_circe2_1, "sf_circe2_1", &
"structure function configuration", &
u, results)
<<SF circe2: test declarations>>=
public :: sf_circe2_1
<<SF circe2: tests>>=
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.
<<SF circe2: execute tests>>=
call test (sf_circe2_2, "sf_circe2_2", &
"generator, unpolarized", &
u, results)
<<SF circe2: test declarations>>=
public :: sf_circe2_2
<<SF circe2: tests>>=
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.
<<SF circe2: execute tests>>=
call test (sf_circe2_3, "sf_circe2_3", &
"generator, polarized", &
u, results)
<<SF circe2: test declarations>>=
public :: sf_circe2_3
<<SF circe2: tests>>=
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]]>>=
<<File header>>
module hoppet_interface
use lhapdf !NODEP!
<<Standard module head>>
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]]>>=
<<File header>>
module sf_pdf_builtin
<<Use kinds>>
use kinds, only: double
<<Use strings>>
use sm_qcd
use pdg_arrays
use model_data
use flavors
use polarizations
use sf_base
<<Standard module head>>
<<SF pdf builtin: public>>
<<SF pdf builtin: types>>
interface
<<SF pdf builtin: sub interfaces>>
end interface
contains
<<SF pdf builtin: main procedures>>
end module sf_pdf_builtin
@ %def sf_pdf_builtin
@
<<[[sf_pdf_builtin_sub.f90]]>>=
<<File header>>
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
<<SF pdf builtin: parameters>>
contains
<<SF pdf builtin: procedures>>
end submodule sf_pdf_builtin_s
@ %def sf_pdf_builtin_s
@
\subsection{Codes for default PDF sets}
<<SF pdf builtin: parameters>>=
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.
<<SF pdf builtin: public>>=
public :: pdf_builtin_data_t
<<SF pdf builtin: types>>=
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
<<SF pdf builtin: pdf builtin data: TBP>>
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.
<<SF pdf builtin: pdf builtin data: TBP>>=
procedure :: init => pdf_builtin_data_init
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: pdf builtin data: TBP>>=
procedure :: set_mask => pdf_builtin_data_set_mask
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: pdf builtin data: TBP>>=
procedure :: write => pdf_builtin_data_write
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: pdf builtin data: TBP>>=
procedure :: get_n_par => pdf_builtin_data_get_n_par
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: pdf builtin data: TBP>>=
procedure :: get_pdg_out => pdf_builtin_data_get_pdg_out
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: pdf builtin data: TBP>>=
procedure :: allocate_sf_int => pdf_builtin_data_allocate_sf_int
<<SF pdf builtin: main procedures>>=
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.
<<SF pdf builtin: pdf builtin data: TBP>>=
procedure :: get_pdf_set => pdf_builtin_data_get_pdf_set
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: public>>=
public :: pdf_builtin_t
<<SF pdf builtin: types>>=
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
<<SF pdf builtin: pdf builtin: TBP>>
end type pdf_builtin_t
@ %def pdf_builtin_t
@ Type string: display the chosen PDF set.
<<SF pdf builtin: pdf builtin: TBP>>=
procedure :: type_string => pdf_builtin_type_string
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: pdf builtin: TBP>>=
procedure :: write => pdf_builtin_write
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: pdf builtin: TBP>>=
procedure :: init => pdf_builtin_init
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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$.
<<SF pdf builtin: pdf builtin: TBP>>=
procedure :: complete_kinematics => pdf_builtin_complete_kinematics
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: pdf builtin: TBP>>=
procedure :: recover_x => pdf_builtin_recover_x
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: pdf builtin: TBP>>=
procedure :: inverse_kinematics => pdf_builtin_inverse_kinematics
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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]].
<<SF pdf builtin: pdf builtin: TBP>>=
procedure :: apply => pdf_builtin_apply
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: public>>=
public :: alpha_qcd_pdf_builtin_t
<<SF pdf builtin: types>>=
type, extends (alpha_qcd_t) :: alpha_qcd_pdf_builtin_t
type(string_t) :: pdfset_name
integer :: pdfset_id = -1
contains
<<SF pdf builtin: alpha qcd: TBP>>
end type alpha_qcd_pdf_builtin_t
@ %def alpha_qcd_pdf_builtin_t
@ Output.
<<SF pdf builtin: alpha qcd: TBP>>=
procedure :: write => alpha_qcd_pdf_builtin_write
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: alpha qcd: TBP>>=
procedure :: get => alpha_qcd_pdf_builtin_get
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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.
<<SF pdf builtin: alpha qcd: TBP>>=
procedure :: init => alpha_qcd_pdf_builtin_init
<<SF pdf builtin: sub interfaces>>=
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
<<SF pdf builtin: procedures>>=
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]]>>=
<<File header>>
module sf_pdf_builtin_ut
use unit_tests
use sf_pdf_builtin_uti
<<Standard module head>>
<<SF pdf builtin: public test>>
contains
<<SF pdf builtin: test driver>>
end module sf_pdf_builtin_ut
@ %def sf_pdf_builtin_ut
@
<<[[sf_pdf_builtin_uti.f90]]>>=
<<File header>>
module sf_pdf_builtin_uti
<<Use kinds>>
<<Use strings>>
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
<<Standard module head>>
<<SF pdf builtin: test declarations>>
contains
<<SF pdf builtin: tests>>
end module sf_pdf_builtin_uti
@ %def sf_pdf_builtin_ut
@ API: driver for the unit tests below.
<<SF pdf builtin: public test>>=
public :: sf_pdf_builtin_test
<<SF pdf builtin: test driver>>=
subroutine sf_pdf_builtin_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF pdf builtin: execute tests>>
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.
<<SF pdf builtin: execute tests>>=
call test (sf_pdf_builtin_1, "sf_pdf_builtin_1", &
"structure function configuration", &
u, results)
<<SF pdf builtin: test declarations>>=
public :: sf_pdf_builtin_1
<<SF pdf builtin: tests>>=
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.
<<SF pdf builtin: execute tests>>=
call test (sf_pdf_builtin_2, "sf_pdf_builtin_2", &
"structure function instance", &
u, results)
<<SF pdf builtin: test declarations>>=
public :: sf_pdf_builtin_2
<<SF pdf builtin: tests>>=
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.
<<SF pdf builtin: execute tests>>=
call test (sf_pdf_builtin_3, "sf_pdf_builtin_3", &
"running alpha_s", &
u, results)
<<SF pdf builtin: test declarations>>=
public :: sf_pdf_builtin_3
<<SF pdf builtin: tests>>=
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]]>>=
<<File header>>
module sf_lhapdf
<<Use kinds>>
<<Use strings>>
use sm_qcd
use pdg_arrays
use model_data
use flavors
use polarizations
use sf_base
use lhapdf !NODEP!
<<Standard module head>>
<<SF lhapdf: public>>
<<SF lhapdf: types>>
<<SF lhapdf: variables>>
<<SF lhapdf: interfaces>>
interface
<<SF lhapdf: sub interfaces>>
end interface
contains
<<SF lhapdf: main procedures>>
end module sf_lhapdf
@ %def sf_lhapdf
@
<<[[sf_lhapdf_sub.f90]]>>=
<<File header>>
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
<<SF lhapdf: parameters>>
contains
<<SF lhapdf: procedures>>
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$).
<<SF lhapdf: parameters>>=
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.
<<SF lhapdf: interfaces>>=
interface
subroutine InitPDFsetM (set, file)
integer, intent(in) :: set
character(*), intent(in) :: file
end subroutine InitPDFsetM
end interface
@ %def InitPDFsetM
<<SF lhapdf: interfaces>>=
interface
subroutine InitPDFM (set, mem)
integer, intent(in) :: set, mem
end subroutine InitPDFM
end interface
@ %def InitPDFM
<<SF lhapdf: interfaces>>=
interface
subroutine numberPDFM (set, n_members)
integer, intent(in) :: set
integer, intent(out) :: n_members
end subroutine numberPDFM
end interface
@ %def numberPDFM
<<SF lhapdf: interfaces>>=
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
<<SF lhapdf: interfaces>>=
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
<<SF lhapdf: interfaces>>=
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
<<SF lhapdf: interfaces>>=
interface
subroutine GetXminM (set, mem, xmin)
integer, intent(in) :: set, mem
double precision, intent(out) :: xmin
end subroutine GetXminM
end interface
@ %def GetXminM
<<SF lhapdf: interfaces>>=
interface
subroutine GetXmaxM (set, mem, xmax)
integer, intent(in) :: set, mem
double precision, intent(out) :: xmax
end subroutine GetXmaxM
end interface
@ %def GetXmaxM
<<SF lhapdf: interfaces>>=
interface
subroutine GetQ2minM (set, mem, q2min)
integer, intent(in) :: set, mem
double precision, intent(out) :: q2min
end subroutine GetQ2minM
end interface
@ %def GetQ2minM
<<SF lhapdf: interfaces>>=
interface
subroutine GetQ2maxM (set, mem, q2max)
integer, intent(in) :: set, mem
double precision, intent(out) :: q2max
end subroutine GetQ2maxM
end interface
@ %def GetQ2maxM
<<SF lhapdf: interfaces>>=
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.
<<SF lhapdf: types>>=
type :: lhapdf_global_status_t
private
logical, dimension(3) :: initialized = .false.
end type lhapdf_global_status_t
@ %def lhapdf_global_status_t
<<SF lhapdf: variables>>=
type(lhapdf_global_status_t), save :: lhapdf_global_status
@ %def lhapdf_global_status
<<SF lhapdf: procedures>>=
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
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: public>>=
public :: lhapdf_global_reset
<<SF lhapdf: sub interfaces>>=
module subroutine lhapdf_global_reset ()
end subroutine lhapdf_global_reset
<<SF lhapdf: procedures>>=
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.).
<<SF lhapdf: public>>=
public :: lhapdf_initialize
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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$.
<<SF lhapdf: lhapdf: TBP>>=
procedure :: complete_kinematics => lhapdf_complete_kinematics
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: lhapdf: TBP>>=
procedure :: recover_x => lhapdf_recover_x
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: lhapdf: TBP>>=
procedure :: inverse_kinematics => lhapdf_inverse_kinematics
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: public>>=
public :: lhapdf_data_t
<<SF lhapdf: types>>=
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
<<SF lhapdf: lhapdf data: TBP>>
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.
<<SF lhapdf: lhapdf data: TBP>>=
procedure :: init => lhapdf_data_init
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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.
<<LHAPDF: lhapdf data: TBP>>=
procedure :: set_mask => lhapdf_data_set_mask
<<LHAPDF: procedures>>=
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.
<<LHAPDF: public>>=
public :: lhapdf_data_get_public_info
<<LHAPDF: procedures>>=
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.
<<LHAPDF: public>>=
public :: lhapdf_data_get_set
<<LHAPDF: procedures>>=
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
<<SF lhapdf: lhapdf data: TBP>>=
procedure :: write => lhapdf_data_write
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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 = ", &
" <empty (non-verbose version)>"
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.
<<SF lhapdf: lhapdf data: TBP>>=
procedure :: get_n_par => lhapdf_data_get_n_par
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: lhapdf data: TBP>>=
procedure :: get_pdg_out => lhapdf_data_get_pdg_out
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: lhapdf data: TBP>>=
procedure :: allocate_sf_int => lhapdf_data_allocate_sf_int
<<SF lhapdf: main procedures>>=
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.
<<SF lhapdf: lhapdf data: TBP>>=
procedure :: get_pdf_set => lhapdf_data_get_pdf_set
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: public>>=
public :: lhapdf_t
<<SF lhapdf: types>>=
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
<<SF lhapdf: lhapdf: TBP>>
end type lhapdf_t
@ %def lhapdf_t
@ Type string: display the chosen PDF set.
<<SF lhapdf: lhapdf: TBP>>=
procedure :: type_string => lhapdf_type_string
<<SF lhapdf: sub interfaces>>=
module function lhapdf_type_string (object) result (string)
class(lhapdf_t), intent(in) :: object
type(string_t) :: string
end function lhapdf_type_string
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: lhapdf: TBP>>=
procedure :: write => lhapdf_write
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: lhapdf: TBP>>=
procedure :: init => lhapdf_init
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: lhapdf: TBP>>=
procedure :: apply => lhapdf_apply
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: public>>=
public :: alpha_qcd_lhapdf_t
<<SF lhapdf: types>>=
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
<<SF lhapdf: alpha qcd: TBP>>
end type alpha_qcd_lhapdf_t
@ %def alpha_qcd_lhapdf_t
@ Output. As in earlier versions we leave the LHAPDF path out.
<<SF lhapdf: alpha qcd: TBP>>=
procedure :: write => alpha_qcd_lhapdf_write
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: interfaces>>=
interface
double precision function alphasPDF (Q)
double precision, intent(in) :: Q
end function alphasPDF
end interface
@ %def alphasPDF
@
<<SF lhapdf: alpha qcd: TBP>>=
procedure :: get => alpha_qcd_lhapdf_get
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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.
<<SF lhapdf: alpha qcd: TBP>>=
procedure :: init => alpha_qcd_lhapdf_init
<<SF lhapdf: sub interfaces>>=
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
<<SF lhapdf: procedures>>=
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
@ Retrieves the quark masses from the PDF.
<<SF lhapdf: alpha qcd: TBP>>=
procedure :: get_qmass => alpha_qcd_lhapdf_get_qmass
<<SF lhapdf: sub interfaces>>=
module function alpha_qcd_lhapdf_get_qmass (alpha_qcd, i_q) result (mq)
real(default) :: mq
class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd
integer, intent(in) :: i_q
end function alpha_qcd_lhapdf_get_qmass
<<SF lhapdf: procedures>>=
module function alpha_qcd_lhapdf_get_qmass (alpha_qcd, i_q) result (mq)
real(default) :: mq
class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd
integer, intent(in) :: i_q
mq = alpha_qcd%pdf%get_qmass (i_q)
end function alpha_qcd_lhapdf_get_qmass
@ %def alpha_qcd_lhapdf_get_qmass
@ Retrieves the order from the PDF.
<<SF lhapdf: alpha qcd: TBP>>=
procedure :: get_order => alpha_qcd_lhapdf_get_order
<<SF lhapdf: sub interfaces>>=
module function alpha_qcd_lhapdf_get_order (alpha_qcd) result (order)
integer :: order
class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd
end function alpha_qcd_lhapdf_get_order
<<SF lhapdf: procedures>>=
module function alpha_qcd_lhapdf_get_order (alpha_qcd) result (order)
integer :: order
class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd
order = alpha_qcd%pdf%get_order ()
end function alpha_qcd_lhapdf_get_order
@ %def alpha_qcd_lhapdf_get_order
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[sf_lhapdf_ut.f90]]>>=
<<File header>>
module sf_lhapdf_ut
use unit_tests
use system_dependencies, only: LHAPDF5_AVAILABLE
use system_dependencies, only: LHAPDF6_AVAILABLE
use sf_lhapdf_uti
<<Standard module head>>
<<SF lhapdf: public test>>
contains
<<SF lhapdf: test driver>>
end module sf_lhapdf_ut
@ %def sf_lhapdf_ut
@
<<[[sf_lhapdf_uti.f90]]>>=
<<File header>>
module sf_lhapdf_uti
<<Use kinds>>
<<Use strings>>
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
<<Standard module head>>
<<SF lhapdf: test declarations>>
contains
<<SF lhapdf: tests>>
end module sf_lhapdf_uti
@ %def sf_lhapdf_ut
@ API: driver for the unit tests below.
<<SF lhapdf: public test>>=
public :: sf_lhapdf_test
<<SF lhapdf: test driver>>=
subroutine sf_lhapdf_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SF lhapdf: execute tests>>
end subroutine sf_lhapdf_test
@ %def sf_lhapdf_test
@
\subsubsection{Test structure function data}
Construct and display a test structure function data object.
<<SF lhapdf: execute tests>>=
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
<<SF lhapdf: test declarations>>=
public :: sf_lhapdf_1
<<SF lhapdf: tests>>=
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.
<<SF lhapdf: execute tests>>=
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
<<SF lhapdf: test declarations>>=
public :: sf_lhapdf_2
<<SF lhapdf: tests>>=
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.
<<SF lhapdf: execute tests>>=
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
<<SF lhapdf: test declarations>>=
public :: sf_lhapdf_3
<<SF lhapdf: tests>>=
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]]>>=
<<File header>>
module pdf
<<Use kinds with double>>
use beam_structures
use lhapdf !NODEP!
use pdf_builtin !NODEP!
<<Standard module head>>
<<PDF: public>>
<<PDF: parameters>>
<<PDF: types>>
interface
<<PDF: sub interfaces>>
end interface
end module pdf
@ %def pdf
@
<<[[pdf_sub.f90]]>>=
<<File header>>
submodule (pdf) pdf_s
use io_units
use system_dependencies, only: LHAPDF5_AVAILABLE, LHAPDF6_AVAILABLE
use diagnostics
implicit none
contains
<<PDF: procedures>>
end submodule pdf_s
@ %def pdf_s
@
We support the following implementations:
<<PDF: parameters>>=
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.
<<PDF: public>>=
public :: pdf_data_t
<<PDF: types>>=
type :: pdf_data_t
type(lhapdf_pdf_t) :: pdf
real(default) :: xmin, xmax, qmin, qmax
integer :: type = STRF_NONE
integer :: set = 0
contains
<<PDF: pdf data: TBP>>
end type pdf_data_t
@ %def pdf_data
@
<<PDF: pdf data: TBP>>=
procedure :: init => pdf_data_init
<<PDF: sub interfaces>>=
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
<<PDF: procedures>>=
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
@
<<PDF: pdf data: TBP>>=
procedure :: write => pdf_data_write
<<PDF: sub interfaces>>=
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
<<PDF: procedures>>=
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
@
<<PDF: pdf data: TBP>>=
procedure :: setup => pdf_data_setup
<<PDF: sub interfaces>>=
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
<<PDF: procedures>>=
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.
<<PDF: pdf data: TBP>>=
procedure :: evolve => pdf_data_evolve
<<PDF: sub interfaces>>=
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
<<PDF: procedures>>=
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]]>>=
<<File header>>
module dispatch_beams
<<Use kinds>>
<<Use strings>>
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
<<Standard module head>>
<<Dispatch beams: public>>
<<Dispatch beams: types>>
<<Dispatch beams: variables>>
interface
<<Dispatch beams: sub interfaces>>
end interface
contains
<<Dispatch beams: main procedures>>
end module dispatch_beams
@ %def dispatch_beams
@
<<[[dispatch_beams_sub.f90]]>>=
<<File header>>
submodule (dispatch_beams) dispatch_beams_s
implicit none
contains
<<Dispatch beams: procedures>>
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.
<<Dispatch beams: public>>=
public :: sf_prop_t
<<Dispatch beams: types>>=
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.
<<Dispatch beams: public>>=
public :: dispatch_sf_data
<<Dispatch beams: main procedures>>=
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.
<<Dispatch beams: public>>=
public :: dispatch_sf_data_extra
<<Dispatch beams: variables>>=
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.
<<Dispatch beams: public>>=
public :: strfun_mode
<<Dispatch beams: sub interfaces>>=
module function strfun_mode (name) result (n)
type(string_t), intent(in) :: name
integer :: n
end function strfun_mode
<<Dispatch beams: procedures>>=
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.
<<Dispatch beams: public>>=
public :: dispatch_sf_config
<<Dispatch beams: sub interfaces>>=
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
<<Dispatch beams: procedures>>=
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.
<<Dispatch beams: public>>=
public :: dispatch_qcd
<<Dispatch beams: main procedures>>=
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
<<Dispatch qcd: dispatch qcd: procedures>>
end subroutine dispatch_qcd
@ %def dispatch_qcd
@
<<Dispatch qcd: dispatch qcd: procedures>>=
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
@
<<Dispatch qcd: dispatch qcd: procedures>>=
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.
<<Dispatch beams: public>>=
public :: dispatch_qed
<<Dispatch beams: main procedures>>=
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
<<Dispatch qed: dispatch qed: procedures>>
end subroutine dispatch_qed
@ %def dispatch_qed
@
<<Dispatch qed: dispatch qed: procedures>>=
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
@
<<Dispatch qed: dispatch qed: procedures>>=
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/src/qft/qft.nw
===================================================================
--- trunk/src/qft/qft.nw (revision 8842)
+++ trunk/src/qft/qft.nw (revision 8843)
@@ -1,18813 +1,18813 @@
%% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: Quantum Field Theory concepts
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Quantum Field Theory Concepts}
\includemodulegraph{qft}
The objects and methods defined here implement concepts and data for
the underlying quantum field theory that we use for computing matrix
elements and processes.
\begin{description}
\item[model\_data]
Fields and coupling parameters, operators as vertex structures, for
a specific model.
\item[model\_testbed]
Provide hooks to deal with a [[model_data]] extension without
referencing it explicitly.
\item[helicities]
Types and methods for spin density matrices.
\item[colors]
Dealing with colored particles, using the color-flow representation.
\item[flavors]
PDG codes and particle properties, depends on the model.
\item[quantum\_numbers]
Quantum numbers and density matrices for entangled particle systems.
\end{description}
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Model Data}
These data represent a specific Lagrangian in numeric terms. That is,
we have the fields with their quantum numbers, the masses, widths and
couplings as numerical values, and the vertices as arrays of fields.
We do not store the relations between coupling parameters. They
should be represented by expressions for evaluation, implemented as
Sindarin objects in a distinct data structure. Neither do we need the
algebraic structure of vertices. The field content of vertices is
required for the sole purpose of setting up phase space.
<<[[model_data.f90]]>>=
<<File header>>
module model_data
use, intrinsic :: iso_c_binding !NODEP!
<<Use kinds>>
use kinds, only: i8, i32
use kinds, only: c_default_float
<<Use strings>>
use physics_defs, only: UNDEFINED, SCALAR
<<Standard module head>>
<<Model data: public>>
<<Model data: types>>
interface
<<Model data: sub interfaces>>
end interface
end module model_data
@ %def model_data
@
<<[[model_data_sub.f90]]>>=
<<File header>>
submodule (model_data) model_data_s
use format_defs, only: FMT_19
use io_units
use diagnostics
use md5
use hashes, only: hash
implicit none
<<Model data: parameters>>
contains
<<Model data: procedures>>
end submodule model_data_s
@ %def model_data_s
@
\subsection{Physics Parameters}
Couplings, masses, and widths are physics parameters. Each parameter
has a unique name (used, essentially, for diagnostics output and
debugging) and a value. The value may be a real or a complex number,
so we provide to implementations of an abstract type.
<<Model data: public>>=
public :: modelpar_data_t
<<Model data: types>>=
type, abstract :: modelpar_data_t
private
type(string_t) :: name
contains
<<Model data: par data: TBP>>
end type modelpar_data_t
type, extends (modelpar_data_t) :: modelpar_real_t
private
real(default) :: value
end type modelpar_real_t
type, extends (modelpar_data_t) :: modelpar_complex_t
private
complex(default) :: value
end type modelpar_complex_t
@ %def modelpar_data_t modelpar_real_t modelpar_complex_t
@
Output for diagnostics. Non-advancing.
<<Model data: par data: TBP>>=
procedure :: write => par_write
<<Model data: sub interfaces>>=
module subroutine par_write (par, unit)
class(modelpar_data_t), intent(in) :: par
integer, intent(in), optional :: unit
end subroutine
<<Model data: procedures>>=
module subroutine par_write (par, unit)
class(modelpar_data_t), intent(in) :: par
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A,1x,A)", advance="no") char (par%name), "= "
select type (par)
type is (modelpar_real_t)
write (u, "(" // FMT_19 // ")", advance="no") par%value
type is (modelpar_complex_t)
write (u, "(" // FMT_19 // ",1x,'+',1x," // FMT_19 // ",1x,'I')", &
advance="no") par%value
end select
end subroutine par_write
@ %def par_write
@
Pretty-printed on separate line, with fixed line length
<<Model data: par data: TBP>>=
procedure :: show => par_show
<<Model data: sub interfaces>>=
module subroutine par_show (par, l, u)
class(modelpar_data_t), intent(in) :: par
integer, intent(in) :: l, u
end subroutine par_show
<<Model data: procedures>>=
module subroutine par_show (par, l, u)
class(modelpar_data_t), intent(in) :: par
integer, intent(in) :: l, u
character(len=l) :: buffer
buffer = par%name
select type (par)
type is (modelpar_real_t)
write (u, "(4x,A,1x,'=',1x," // FMT_19 // ")") buffer, par%value
type is (modelpar_complex_t)
write (u, "(4x,A,1x,'=',1x," // FMT_19 // ",1x,'+',1x," &
// FMT_19 // ",1x,'I')") buffer, par%value
end select
end subroutine par_show
@ %def par_show
@
Initialize with name and value. The type depends on the argument
type. If the type does not match, the value is converted following
Fortran rules.
<<Model data: par data: TBP>>=
generic :: init => modelpar_data_init_real, modelpar_data_init_complex
procedure, private :: modelpar_data_init_real
procedure, private :: modelpar_data_init_complex
<<Model data: sub interfaces>>=
module subroutine modelpar_data_init_real (par, name, value)
class(modelpar_data_t), intent(out) :: par
type(string_t), intent(in) :: name
real(default), intent(in) :: value
end subroutine modelpar_data_init_real
module subroutine modelpar_data_init_complex (par, name, value)
class(modelpar_data_t), intent(out) :: par
type(string_t), intent(in) :: name
complex(default), intent(in) :: value
end subroutine modelpar_data_init_complex
<<Model data: procedures>>=
module subroutine modelpar_data_init_real (par, name, value)
class(modelpar_data_t), intent(out) :: par
type(string_t), intent(in) :: name
real(default), intent(in) :: value
par%name = name
par = value
end subroutine modelpar_data_init_real
module subroutine modelpar_data_init_complex (par, name, value)
class(modelpar_data_t), intent(out) :: par
type(string_t), intent(in) :: name
complex(default), intent(in) :: value
par%name = name
par = value
end subroutine modelpar_data_init_complex
@ %def modelpar_data_init_real modelpar_data_init_complex
@
Modify the value. We assume that the parameter has been
initialized. The type (real or complex) must not be changed, and the
name is also fixed.
<<Model data: par data: TBP>>=
generic :: assignment(=) => modelpar_data_set_real, modelpar_data_set_complex
procedure, private :: modelpar_data_set_real
procedure, private :: modelpar_data_set_complex
<<Model data: sub interfaces>>=
elemental module subroutine modelpar_data_set_real (par, value)
class(modelpar_data_t), intent(inout) :: par
real(default), intent(in) :: value
end subroutine modelpar_data_set_real
elemental module subroutine modelpar_data_set_complex (par, value)
class(modelpar_data_t), intent(inout) :: par
complex(default), intent(in) :: value
end subroutine modelpar_data_set_complex
<<Model data: procedures>>=
elemental module subroutine modelpar_data_set_real (par, value)
class(modelpar_data_t), intent(inout) :: par
real(default), intent(in) :: value
select type (par)
type is (modelpar_real_t)
par%value = value
type is (modelpar_complex_t)
par%value = value
end select
end subroutine modelpar_data_set_real
elemental module subroutine modelpar_data_set_complex (par, value)
class(modelpar_data_t), intent(inout) :: par
complex(default), intent(in) :: value
select type (par)
type is (modelpar_real_t)
par%value = value
type is (modelpar_complex_t)
par%value = value
end select
end subroutine modelpar_data_set_complex
@ %def modelpar_data_set_real modelpar_data_set_complex
@
Return the parameter name.
<<Model data: par data: TBP>>=
procedure :: get_name => modelpar_data_get_name
<<Model data: sub interfaces>>=
module function modelpar_data_get_name (par) result (name)
class(modelpar_data_t), intent(in) :: par
type(string_t) :: name
end function modelpar_data_get_name
<<Model data: procedures>>=
module function modelpar_data_get_name (par) result (name)
class(modelpar_data_t), intent(in) :: par
type(string_t) :: name
name = par%name
end function modelpar_data_get_name
@ %def modelpar_data_get_name
@
Return the value. In case of a type mismatch, follow Fortran conventions.
<<Model data: par data: TBP>>=
procedure, pass :: get_real => modelpar_data_get_real
procedure, pass :: get_complex => modelpar_data_get_complex
<<Model data: sub interfaces>>=
elemental module function modelpar_data_get_real (par) result (value)
class(modelpar_data_t), intent(in), target :: par
real(default) :: value
end function modelpar_data_get_real
elemental module function modelpar_data_get_complex (par) result (value)
class(modelpar_data_t), intent(in), target :: par
complex(default) :: value
end function modelpar_data_get_complex
<<Model data: procedures>>=
elemental module function modelpar_data_get_real (par) result (value)
class(modelpar_data_t), intent(in), target :: par
real(default) :: value
select type (par)
type is (modelpar_real_t)
value = par%value
type is (modelpar_complex_t)
value = par%value
end select
end function modelpar_data_get_real
elemental module function modelpar_data_get_complex (par) result (value)
class(modelpar_data_t), intent(in), target :: par
complex(default) :: value
select type (par)
type is (modelpar_real_t)
value = par%value
type is (modelpar_complex_t)
value = par%value
end select
end function modelpar_data_get_complex
@ %def modelpar_data_get_real
@ %def modelpar_data_get_complex
@
Return a pointer to the value. This makes sense only for matching types.
<<Model data: par data: TBP>>=
procedure :: get_real_ptr => modelpar_data_get_real_ptr
procedure :: get_complex_ptr => modelpar_data_get_complex_ptr
<<Model data: sub interfaces>>=
module function modelpar_data_get_real_ptr (par) result (ptr)
class(modelpar_data_t), intent(in), target :: par
real(default), pointer :: ptr
end function modelpar_data_get_real_ptr
module function modelpar_data_get_complex_ptr (par) result (ptr)
class(modelpar_data_t), intent(in), target :: par
complex(default), pointer :: ptr
end function modelpar_data_get_complex_ptr
<<Model data: procedures>>=
module function modelpar_data_get_real_ptr (par) result (ptr)
class(modelpar_data_t), intent(in), target :: par
real(default), pointer :: ptr
select type (par)
type is (modelpar_real_t)
ptr => par%value
class default
ptr => null ()
end select
end function modelpar_data_get_real_ptr
module function modelpar_data_get_complex_ptr (par) result (ptr)
class(modelpar_data_t), intent(in), target :: par
complex(default), pointer :: ptr
select type (par)
type is (modelpar_complex_t)
ptr => par%value
class default
ptr => null ()
end select
end function modelpar_data_get_complex_ptr
@ %def modelpar_data_get_real_ptr
@ %def modelpar_data_get_complex_ptr
@
\subsection{Field Data}
The field-data type holds all information that pertains to a particular field
(or particle) within a particular model. Information such as spin type,
particle code etc.\ is stored within the object itself, while mass and width
are associated to parameters, otherwise assumed zero.
<<Model data: public>>=
public :: field_data_t
<<Model data: types>>=
type :: field_data_t
private
type(string_t) :: longname
integer :: pdg = UNDEFINED
logical :: visible = .true.
logical :: parton = .false.
logical :: gauge = .false.
logical :: left_handed = .false.
logical :: right_handed = .false.
logical :: has_anti = .false.
logical :: p_is_stable = .true.
logical :: p_decays_isotropically = .false.
logical :: p_decays_diagonal = .false.
logical :: p_has_decay_helicity = .false.
integer :: p_decay_helicity = 0
logical :: a_is_stable = .true.
logical :: a_decays_isotropically = .false.
logical :: a_decays_diagonal = .false.
logical :: a_has_decay_helicity = .false.
integer :: a_decay_helicity = 0
logical :: p_polarized = .false.
logical :: a_polarized = .false.
type(string_t), dimension(:), allocatable :: name, anti
type(string_t) :: tex_name, tex_anti
integer :: spin_type = UNDEFINED
integer :: isospin_type = 1
integer :: charge_type = 1
integer :: color_type = 1
real(default), pointer :: mass_val => null ()
class(modelpar_data_t), pointer :: mass_data => null ()
real(default), pointer :: width_val => null ()
class(modelpar_data_t), pointer :: width_data => null ()
integer :: multiplicity = 1
type(string_t), dimension(:), allocatable :: p_decay
type(string_t), dimension(:), allocatable :: a_decay
contains
<<Model data: field data: TBP>>
end type field_data_t
@ %def field_data_t
@ Initialize field data with PDG long name and PDG code. \TeX\
names should be initialized to avoid issues with accessing
unallocated string contents.
<<Model data: field data: TBP>>=
procedure :: init => field_data_init
<<Model data: sub interfaces>>=
module subroutine field_data_init (prt, longname, pdg)
class(field_data_t), intent(out) :: prt
type(string_t), intent(in) :: longname
integer, intent(in) :: pdg
end subroutine field_data_init
<<Model data: procedures>>=
module subroutine field_data_init (prt, longname, pdg)
class(field_data_t), intent(out) :: prt
type(string_t), intent(in) :: longname
integer, intent(in) :: pdg
prt%longname = longname
prt%pdg = pdg
prt%tex_name = ""
prt%tex_anti = ""
end subroutine field_data_init
@ %def field_data_init
@ Copy quantum numbers from another particle. Do not compute the multiplicity
yet, because this depends on the association of the [[mass_data]] pointer.
<<Model data: field data: TBP>>=
procedure :: copy_from => field_data_copy_from
<<Model data: sub interfaces>>=
module subroutine field_data_copy_from (prt, prt_src)
class(field_data_t), intent(inout) :: prt
class(field_data_t), intent(in) :: prt_src
end subroutine field_data_copy_from
<<Model data: procedures>>=
module subroutine field_data_copy_from (prt, prt_src)
class(field_data_t), intent(inout) :: prt
class(field_data_t), intent(in) :: prt_src
prt%visible = prt_src%visible
prt%parton = prt_src%parton
prt%gauge = prt_src%gauge
prt%left_handed = prt_src%left_handed
prt%right_handed = prt_src%right_handed
prt%p_is_stable = prt_src%p_is_stable
prt%p_decays_isotropically = prt_src%p_decays_isotropically
prt%p_decays_diagonal = prt_src%p_decays_diagonal
prt%p_has_decay_helicity = prt_src%p_has_decay_helicity
prt%p_decay_helicity = prt_src%p_decay_helicity
prt%p_decays_diagonal = prt_src%p_decays_diagonal
prt%a_is_stable = prt_src%a_is_stable
prt%a_decays_isotropically = prt_src%a_decays_isotropically
prt%a_decays_diagonal = prt_src%a_decays_diagonal
prt%a_has_decay_helicity = prt_src%a_has_decay_helicity
prt%a_decay_helicity = prt_src%a_decay_helicity
prt%p_polarized = prt_src%p_polarized
prt%a_polarized = prt_src%a_polarized
prt%spin_type = prt_src%spin_type
prt%isospin_type = prt_src%isospin_type
prt%charge_type = prt_src%charge_type
prt%color_type = prt_src%color_type
prt%has_anti = prt_src%has_anti
if (allocated (prt_src%name)) then
if (allocated (prt%name)) deallocate (prt%name)
allocate (prt%name (size (prt_src%name)), source = prt_src%name)
end if
if (allocated (prt_src%anti)) then
if (allocated (prt%anti)) deallocate (prt%anti)
allocate (prt%anti (size (prt_src%anti)), source = prt_src%anti)
end if
prt%tex_name = prt_src%tex_name
prt%tex_anti = prt_src%tex_anti
if (allocated (prt_src%p_decay)) then
if (allocated (prt%p_decay)) deallocate (prt%p_decay)
allocate (prt%p_decay (size (prt_src%p_decay)), source = prt_src%p_decay)
end if
if (allocated (prt_src%a_decay)) then
if (allocated (prt%a_decay)) deallocate (prt%a_decay)
allocate (prt%a_decay (size (prt_src%a_decay)), source = prt_src%a_decay)
end if
end subroutine field_data_copy_from
@ %def field_data_copy_from
@ Set particle quantum numbers.
<<Model data: field data: TBP>>=
procedure :: set => field_data_set
<<Model data: sub interfaces>>=
module subroutine field_data_set (prt, &
is_visible, is_parton, is_gauge, is_left_handed, is_right_handed, &
p_is_stable, p_decays_isotropically, p_decays_diagonal, &
p_decay_helicity, &
a_is_stable, a_decays_isotropically, a_decays_diagonal, &
a_decay_helicity, &
p_polarized, a_polarized, &
name, anti, tex_name, tex_anti, &
spin_type, isospin_type, charge_type, color_type, &
mass_data, width_data, &
p_decay, a_decay)
class(field_data_t), intent(inout) :: prt
logical, intent(in), optional :: is_visible, is_parton, is_gauge
logical, intent(in), optional :: is_left_handed, is_right_handed
logical, intent(in), optional :: p_is_stable
logical, intent(in), optional :: p_decays_isotropically, p_decays_diagonal
integer, intent(in), optional :: p_decay_helicity
logical, intent(in), optional :: a_is_stable
logical, intent(in), optional :: a_decays_isotropically, a_decays_diagonal
integer, intent(in), optional :: a_decay_helicity
logical, intent(in), optional :: p_polarized, a_polarized
type(string_t), dimension(:), intent(in), optional :: name, anti
type(string_t), intent(in), optional :: tex_name, tex_anti
integer, intent(in), optional :: spin_type, isospin_type
integer, intent(in), optional :: charge_type, color_type
class(modelpar_data_t), intent(in), pointer, optional :: mass_data, width_data
type(string_t), dimension(:), intent(in), optional :: p_decay, a_decay
end subroutine field_data_set
<<Model data: procedures>>=
module subroutine field_data_set (prt, &
is_visible, is_parton, is_gauge, is_left_handed, is_right_handed, &
p_is_stable, p_decays_isotropically, p_decays_diagonal, &
p_decay_helicity, &
a_is_stable, a_decays_isotropically, a_decays_diagonal, &
a_decay_helicity, &
p_polarized, a_polarized, &
name, anti, tex_name, tex_anti, &
spin_type, isospin_type, charge_type, color_type, &
mass_data, width_data, &
p_decay, a_decay)
class(field_data_t), intent(inout) :: prt
logical, intent(in), optional :: is_visible, is_parton, is_gauge
logical, intent(in), optional :: is_left_handed, is_right_handed
logical, intent(in), optional :: p_is_stable
logical, intent(in), optional :: p_decays_isotropically, p_decays_diagonal
integer, intent(in), optional :: p_decay_helicity
logical, intent(in), optional :: a_is_stable
logical, intent(in), optional :: a_decays_isotropically, a_decays_diagonal
integer, intent(in), optional :: a_decay_helicity
logical, intent(in), optional :: p_polarized, a_polarized
type(string_t), dimension(:), intent(in), optional :: name, anti
type(string_t), intent(in), optional :: tex_name, tex_anti
integer, intent(in), optional :: spin_type, isospin_type
integer, intent(in), optional :: charge_type, color_type
class(modelpar_data_t), intent(in), pointer, optional :: mass_data, width_data
type(string_t), dimension(:), intent(in), optional :: p_decay, a_decay
if (present (is_visible)) prt%visible = is_visible
if (present (is_parton)) prt%parton = is_parton
if (present (is_gauge)) prt%gauge = is_gauge
if (present (is_left_handed)) prt%left_handed = is_left_handed
if (present (is_right_handed)) prt%right_handed = is_right_handed
if (present (p_is_stable)) prt%p_is_stable = p_is_stable
if (present (p_decays_isotropically)) &
prt%p_decays_isotropically = p_decays_isotropically
if (present (p_decays_diagonal)) &
prt%p_decays_diagonal = p_decays_diagonal
if (present (p_decay_helicity)) then
prt%p_has_decay_helicity = .true.
prt%p_decay_helicity = p_decay_helicity
end if
if (present (a_is_stable)) prt%a_is_stable = a_is_stable
if (present (a_decays_isotropically)) &
prt%a_decays_isotropically = a_decays_isotropically
if (present (a_decays_diagonal)) &
prt%a_decays_diagonal = a_decays_diagonal
if (present (a_decay_helicity)) then
prt%a_has_decay_helicity = .true.
prt%a_decay_helicity = a_decay_helicity
end if
if (present (p_polarized)) prt%p_polarized = p_polarized
if (present (a_polarized)) prt%a_polarized = a_polarized
if (present (name)) then
if (allocated (prt%name)) deallocate (prt%name)
allocate (prt%name (size (name)), source = name)
end if
if (present (anti)) then
if (allocated (prt%anti)) deallocate (prt%anti)
allocate (prt%anti (size (anti)), source = anti)
prt%has_anti = .true.
end if
if (present (tex_name)) prt%tex_name = tex_name
if (present (tex_anti)) prt%tex_anti = tex_anti
if (present (spin_type)) prt%spin_type = spin_type
if (present (isospin_type)) prt%isospin_type = isospin_type
if (present (charge_type)) prt%charge_type = charge_type
if (present (color_type)) prt%color_type = color_type
if (present (mass_data)) then
prt%mass_data => mass_data
if (associated (mass_data)) then
prt%mass_val => mass_data%get_real_ptr ()
else
prt%mass_val => null ()
end if
end if
if (present (width_data)) then
prt%width_data => width_data
if (associated (width_data)) then
prt%width_val => width_data%get_real_ptr ()
else
prt%width_val => null ()
end if
end if
if (present (spin_type) .or. present (mass_data)) then
call prt%set_multiplicity ()
end if
if (present (p_decay)) then
if (allocated (prt%p_decay)) deallocate (prt%p_decay)
if (size (p_decay) > 0) &
allocate (prt%p_decay (size (p_decay)), source = p_decay)
end if
if (present (a_decay)) then
if (allocated (prt%a_decay)) deallocate (prt%a_decay)
if (size (a_decay) > 0) &
allocate (prt%a_decay (size (a_decay)), source = a_decay)
end if
end subroutine field_data_set
@ %def field_data_set
@ Calculate the multiplicity given spin type and mass.
<<Model data: field data: TBP>>=
procedure, private :: &
set_multiplicity => field_data_set_multiplicity
<<Model data: sub interfaces>>=
module subroutine field_data_set_multiplicity (prt)
class(field_data_t), intent(inout) :: prt
end subroutine field_data_set_multiplicity
<<Model data: procedures>>=
module subroutine field_data_set_multiplicity (prt)
class(field_data_t), intent(inout) :: prt
if (prt%spin_type /= SCALAR) then
if (associated (prt%mass_data)) then
prt%multiplicity = prt%spin_type
else if (prt%left_handed .or. prt%right_handed) then
prt%multiplicity = 1
else
prt%multiplicity = 2
end if
end if
end subroutine field_data_set_multiplicity
@ %def field_data_set_multiplicity
@ Set the mass/width value (not the pointer). The mass/width pointer
must be allocated.
<<Model data: field data: TBP>>=
procedure, private :: set_mass => field_data_set_mass
procedure, private :: set_width => field_data_set_width
<<Model data: sub interfaces>>=
module subroutine field_data_set_mass (prt, mass)
class(field_data_t), intent(inout) :: prt
real(default), intent(in) :: mass
end subroutine field_data_set_mass
module subroutine field_data_set_width (prt, width)
class(field_data_t), intent(inout) :: prt
real(default), intent(in) :: width
end subroutine field_data_set_width
<<Model data: procedures>>=
module subroutine field_data_set_mass (prt, mass)
class(field_data_t), intent(inout) :: prt
real(default), intent(in) :: mass
if (associated (prt%mass_val)) prt%mass_val = mass
end subroutine field_data_set_mass
module subroutine field_data_set_width (prt, width)
class(field_data_t), intent(inout) :: prt
real(default), intent(in) :: width
if (associated (prt%width_val)) prt%width_val = width
end subroutine field_data_set_width
@ %def field_data_set_mass field_data_set_width
@ Loose ends: name arrays should be allocated.
<<Model data: field data: TBP>>=
procedure :: freeze => field_data_freeze
<<Model data: sub interfaces>>=
elemental module subroutine field_data_freeze (prt)
class(field_data_t), intent(inout) :: prt
end subroutine field_data_freeze
<<Model data: procedures>>=
elemental module subroutine field_data_freeze (prt)
class(field_data_t), intent(inout) :: prt
if (.not. allocated (prt%name)) allocate (prt%name (0))
if (.not. allocated (prt%anti)) allocate (prt%anti (0))
end subroutine field_data_freeze
@ %def field_data_freeze
@ Output
<<Model data: field data: TBP>>=
procedure :: write => field_data_write
<<Model data: sub interfaces>>=
module subroutine field_data_write (prt, unit)
class(field_data_t), intent(in) :: prt
integer, intent(in), optional :: unit
end subroutine field_data_write
<<Model data: procedures>>=
module subroutine field_data_write (prt, unit)
class(field_data_t), intent(in) :: prt
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(3x,A,1x,A)", advance="no") "particle", char (prt%longname)
write (u, "(1x,I0)", advance="no") prt%pdg
if (.not. prt%visible) write (u, "(2x,A)", advance="no") "invisible"
if (prt%parton) write (u, "(2x,A)", advance="no") "parton"
if (prt%gauge) write (u, "(2x,A)", advance="no") "gauge"
if (prt%left_handed) write (u, "(2x,A)", advance="no") "left"
if (prt%right_handed) write (u, "(2x,A)", advance="no") "right"
write (u, *)
write (u, "(5x,A)", advance="no") "name"
if (allocated (prt%name)) then
do i = 1, size (prt%name)
write (u, "(1x,A)", advance="no") '"' // char (prt%name(i)) // '"'
end do
write (u, *)
if (prt%has_anti) then
write (u, "(5x,A)", advance="no") "anti"
do i = 1, size (prt%anti)
write (u, "(1x,A)", advance="no") '"' // char (prt%anti(i)) // '"'
end do
write (u, *)
end if
if (prt%tex_name /= "") then
write (u, "(5x,A)") &
"tex_name " // '"' // char (prt%tex_name) // '"'
end if
if (prt%has_anti .and. prt%tex_anti /= "") then
write (u, "(5x,A)") &
"tex_anti " // '"' // char (prt%tex_anti) // '"'
end if
else
write (u, "(A)") "???"
end if
write (u, "(5x,A)", advance="no") "spin "
select case (mod (prt%spin_type - 1, 2))
case (0); write (u, "(I0)", advance="no") (prt%spin_type-1) / 2
case default; write (u, "(I0,A)", advance="no") prt%spin_type-1, "/2"
end select
! write (u, "(2x,A,I1,A)") "! [multiplicity = ", prt%multiplicity, "]"
if (abs (prt%isospin_type) /= 1) then
write (u, "(2x,A)", advance="no") "isospin "
select case (mod (abs (prt%isospin_type) - 1, 2))
case (0); write (u, "(I0)", advance="no") &
sign (abs (prt%isospin_type) - 1, prt%isospin_type) / 2
case default; write (u, "(I0,A)", advance="no") &
sign (abs (prt%isospin_type) - 1, prt%isospin_type), "/2"
end select
end if
if (abs (prt%charge_type) /= 1) then
write (u, "(2x,A)", advance="no") "charge "
select case (mod (abs (prt%charge_type) - 1, 3))
case (0); write (u, "(I0)", advance="no") &
sign (abs (prt%charge_type) - 1, prt%charge_type) / 3
case default; write (u, "(I0,A)", advance="no") &
sign (abs (prt%charge_type) - 1, prt%charge_type), "/3"
end select
end if
if (prt%color_type /= 1) then
write (u, "(2x,A,I0)", advance="no") "color ", prt%color_type
end if
write (u, *)
if (associated (prt%mass_data)) then
write (u, "(5x,A)", advance="no") &
"mass " // char (prt%mass_data%get_name ())
if (associated (prt%width_data)) then
write (u, "(2x,A)") &
"width " // char (prt%width_data%get_name ())
else
write (u, *)
end if
end if
call prt%write_decays (u)
end subroutine field_data_write
@ %def field_data_write
@ Write decay and polarization data.
<<Model data: field data: TBP>>=
procedure :: write_decays => field_data_write_decays
<<Model data: sub interfaces>>=
module subroutine field_data_write_decays (prt, unit)
class(field_data_t), intent(in) :: prt
integer, intent(in), optional :: unit
end subroutine field_data_write_decays
<<Model data: procedures>>=
module subroutine field_data_write_decays (prt, unit)
class(field_data_t), intent(in) :: prt
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
if (.not. prt%p_is_stable) then
if (allocated (prt%p_decay)) then
write (u, "(5x,A)", advance="no") "p_decay"
do i = 1, size (prt%p_decay)
write (u, "(1x,A)", advance="no") char (prt%p_decay(i))
end do
if (prt%p_decays_isotropically) then
write (u, "(1x,A)", advance="no") "isotropic"
else if (prt%p_decays_diagonal) then
write (u, "(1x,A)", advance="no") "diagonal"
else if (prt%p_has_decay_helicity) then
write (u, "(1x,A,I0)", advance="no") "helicity = ", &
prt%p_decay_helicity
end if
write (u, *)
end if
else if (prt%p_polarized) then
write (u, "(5x,A)") "p_polarized"
end if
if (.not. prt%a_is_stable) then
if (allocated (prt%a_decay)) then
write (u, "(5x,A)", advance="no") "a_decay"
do i = 1, size (prt%a_decay)
write (u, "(1x,A)", advance="no") char (prt%a_decay(i))
end do
if (prt%a_decays_isotropically) then
write (u, "(1x,A)", advance="no") "isotropic"
else if (prt%a_decays_diagonal) then
write (u, "(1x,A)", advance="no") "diagonal"
else if (prt%a_has_decay_helicity) then
write (u, "(1x,A,I0)", advance="no") "helicity = ", &
prt%a_decay_helicity
end if
write (u, *)
end if
else if (prt%a_polarized) then
write (u, "(5x,A)") "a_polarized"
end if
end subroutine field_data_write_decays
@ %def field_data_write_decays
@ Screen version of output.
<<Model data: field data: TBP>>=
procedure :: show => field_data_show
<<Model data: sub interfaces>>=
module subroutine field_data_show (prt, l, u)
class(field_data_t), intent(in) :: prt
integer, intent(in) :: l, u
end subroutine field_data_show
<<Model data: procedures>>=
module subroutine field_data_show (prt, l, u)
class(field_data_t), intent(in) :: prt
integer, intent(in) :: l, u
character(len=l) :: buffer
integer :: i
type(string_t), dimension(:), allocatable :: decay
buffer = prt%get_name (.false.)
write (u, "(4x,A,1x,I8)", advance="no") buffer, &
prt%get_pdg ()
if (prt%is_polarized ()) then
write (u, "(3x,A)") "polarized"
else if (.not. prt%is_stable ()) then
write (u, "(3x,A)", advance="no") "decays:"
call prt%get_decays (decay)
do i = 1, size (decay)
write (u, "(1x,A)", advance="no") char (decay(i))
end do
write (u, *)
else
write (u, *)
end if
if (prt%has_antiparticle ()) then
buffer = prt%get_name (.true.)
write (u, "(4x,A,1x,I8)", advance="no") buffer, &
prt%get_pdg_anti ()
if (prt%is_polarized (.true.)) then
write (u, "(3x,A)") "polarized"
else if (.not. prt%is_stable (.true.)) then
write (u, "(3x,A)", advance="no") "decays:"
call prt%get_decays (decay, .true.)
do i = 1, size (decay)
write (u, "(1x,A)", advance="no") char (decay(i))
end do
write (u, *)
else
write (u, *)
end if
end if
end subroutine field_data_show
@ %def field_data_show
@ Retrieve data:
<<Model data: field data: TBP>>=
procedure :: get_pdg => field_data_get_pdg
procedure :: get_pdg_anti => field_data_get_pdg_anti
<<Model data: sub interfaces>>=
elemental module function field_data_get_pdg (prt) result (pdg)
integer :: pdg
class(field_data_t), intent(in) :: prt
end function field_data_get_pdg
elemental module function field_data_get_pdg_anti (prt) result (pdg)
integer :: pdg
class(field_data_t), intent(in) :: prt
end function field_data_get_pdg_anti
<<Model data: procedures>>=
elemental module function field_data_get_pdg (prt) result (pdg)
integer :: pdg
class(field_data_t), intent(in) :: prt
pdg = prt%pdg
end function field_data_get_pdg
elemental module function field_data_get_pdg_anti (prt) result (pdg)
integer :: pdg
class(field_data_t), intent(in) :: prt
if (prt%has_anti) then
pdg = - prt%pdg
else
pdg = prt%pdg
end if
end function field_data_get_pdg_anti
@ %def field_data_get_pdg field_data_get_pdg_anti
@ Predicates:
<<Model data: field data: TBP>>=
procedure :: is_visible => field_data_is_visible
procedure :: is_parton => field_data_is_parton
procedure :: is_gauge => field_data_is_gauge
procedure :: is_left_handed => field_data_is_left_handed
procedure :: is_right_handed => field_data_is_right_handed
procedure :: has_antiparticle => field_data_has_antiparticle
procedure :: is_stable => field_data_is_stable
procedure :: get_decays => field_data_get_decays
procedure :: decays_isotropically => field_data_decays_isotropically
procedure :: decays_diagonal => field_data_decays_diagonal
procedure :: has_decay_helicity => field_data_has_decay_helicity
procedure :: decay_helicity => field_data_decay_helicity
procedure :: is_polarized => field_data_is_polarized
<<Model data: sub interfaces>>=
elemental module function field_data_is_visible (prt) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
end function field_data_is_visible
elemental module function field_data_is_parton (prt) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
end function field_data_is_parton
elemental module function field_data_is_gauge (prt) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
end function field_data_is_gauge
elemental module function field_data_is_left_handed (prt) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
end function field_data_is_left_handed
elemental module function field_data_is_right_handed (prt) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
end function field_data_is_right_handed
elemental module function field_data_has_antiparticle (prt) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
end function field_data_has_antiparticle
elemental module function field_data_is_stable (prt, anti) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
logical, intent(in), optional :: anti
end function field_data_is_stable
module subroutine field_data_get_decays (prt, decay, anti)
class(field_data_t), intent(in) :: prt
type(string_t), dimension(:), intent(out), allocatable :: decay
logical, intent(in), optional :: anti
end subroutine field_data_get_decays
elemental module function field_data_decays_isotropically &
(prt, anti) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
logical, intent(in), optional :: anti
end function field_data_decays_isotropically
elemental module function field_data_decays_diagonal &
(prt, anti) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
logical, intent(in), optional :: anti
end function field_data_decays_diagonal
elemental module function field_data_has_decay_helicity &
(prt, anti) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
logical, intent(in), optional :: anti
end function field_data_has_decay_helicity
elemental module function field_data_decay_helicity &
(prt, anti) result (hel)
integer :: hel
class(field_data_t), intent(in) :: prt
logical, intent(in), optional :: anti
end function field_data_decay_helicity
elemental module function field_data_is_polarized (prt, anti) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
logical, intent(in), optional :: anti
end function field_data_is_polarized
<<Model data: procedures>>=
elemental module function field_data_is_visible (prt) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
flag = prt%visible
end function field_data_is_visible
elemental module function field_data_is_parton (prt) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
flag = prt%parton
end function field_data_is_parton
elemental module function field_data_is_gauge (prt) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
flag = prt%gauge
end function field_data_is_gauge
elemental module function field_data_is_left_handed (prt) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
flag = prt%left_handed
end function field_data_is_left_handed
elemental module function field_data_is_right_handed (prt) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
flag = prt%right_handed
end function field_data_is_right_handed
elemental module function field_data_has_antiparticle (prt) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
flag = prt%has_anti
end function field_data_has_antiparticle
elemental module function field_data_is_stable (prt, anti) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
logical, intent(in), optional :: anti
if (present (anti)) then
if (anti) then
flag = prt%a_is_stable
else
flag = prt%p_is_stable
end if
else
flag = prt%p_is_stable
end if
end function field_data_is_stable
module subroutine field_data_get_decays (prt, decay, anti)
class(field_data_t), intent(in) :: prt
type(string_t), dimension(:), intent(out), allocatable :: decay
logical, intent(in), optional :: anti
if (present (anti)) then
if (anti) then
allocate (decay (size (prt%a_decay)), source = prt%a_decay)
else
allocate (decay (size (prt%p_decay)), source = prt%p_decay)
end if
else
allocate (decay (size (prt%p_decay)), source = prt%p_decay)
end if
end subroutine field_data_get_decays
elemental module function field_data_decays_isotropically &
(prt, anti) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
logical, intent(in), optional :: anti
if (present (anti)) then
if (anti) then
flag = prt%a_decays_isotropically
else
flag = prt%p_decays_isotropically
end if
else
flag = prt%p_decays_isotropically
end if
end function field_data_decays_isotropically
elemental module function field_data_decays_diagonal &
(prt, anti) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
logical, intent(in), optional :: anti
if (present (anti)) then
if (anti) then
flag = prt%a_decays_diagonal
else
flag = prt%p_decays_diagonal
end if
else
flag = prt%p_decays_diagonal
end if
end function field_data_decays_diagonal
elemental module function field_data_has_decay_helicity &
(prt, anti) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
logical, intent(in), optional :: anti
if (present (anti)) then
if (anti) then
flag = prt%a_has_decay_helicity
else
flag = prt%p_has_decay_helicity
end if
else
flag = prt%p_has_decay_helicity
end if
end function field_data_has_decay_helicity
elemental module function field_data_decay_helicity &
(prt, anti) result (hel)
integer :: hel
class(field_data_t), intent(in) :: prt
logical, intent(in), optional :: anti
if (present (anti)) then
if (anti) then
hel = prt%a_decay_helicity
else
hel = prt%p_decay_helicity
end if
else
hel = prt%p_decay_helicity
end if
end function field_data_decay_helicity
elemental module function field_data_is_polarized (prt, anti) result (flag)
logical :: flag
class(field_data_t), intent(in) :: prt
logical, intent(in), optional :: anti
logical :: a
if (present (anti)) then
a = anti
else
a = .false.
end if
if (a) then
flag = prt%a_polarized
else
flag = prt%p_polarized
end if
end function field_data_is_polarized
@ %def field_data_is_visible field_data_is_parton
@ %def field_data_is_gauge
@ %def field_data_is_left_handed field_data_is_right_handed
@ %def field_data_has_antiparticle
@ %def field_data_is_stable
@ %def field_data_decays_isotropically
@ %def field_data_decays_diagonal
@ %def field_data_has_decay_helicity
@ %def field_data_decay_helicity
@ %def field_data_polarized
@ Names. Return the first name in the list (or the first antiparticle name)
<<Model data: field data: TBP>>=
procedure :: get_longname => field_data_get_longname
procedure :: get_name => field_data_get_name
procedure :: get_name_array => field_data_get_name_array
<<Model data: sub interfaces>>=
pure module function field_data_get_longname (prt) result (name)
type(string_t) :: name
class(field_data_t), intent(in) :: prt
end function field_data_get_longname
pure module function field_data_get_name &
(prt, is_antiparticle) result (name)
type(string_t) :: name
class(field_data_t), intent(in) :: prt
logical, intent(in) :: is_antiparticle
end function field_data_get_name
module subroutine field_data_get_name_array (prt, is_antiparticle, name)
class(field_data_t), intent(in) :: prt
logical, intent(in) :: is_antiparticle
type(string_t), dimension(:), allocatable, intent(inout) :: name
end subroutine field_data_get_name_array
<<Model data: procedures>>=
pure module function field_data_get_longname (prt) result (name)
type(string_t) :: name
class(field_data_t), intent(in) :: prt
name = prt%longname
end function field_data_get_longname
pure module function field_data_get_name (prt, is_antiparticle) result (name)
type(string_t) :: name
class(field_data_t), intent(in) :: prt
logical, intent(in) :: is_antiparticle
name = prt%longname
if (is_antiparticle) then
if (prt%has_anti) then
if (allocated (prt%anti)) then
if (size(prt%anti) > 0) name = prt%anti(1)
end if
else
if (allocated (prt%name)) then
if (size (prt%name) > 0) name = prt%name(1)
end if
end if
else
if (allocated (prt%name)) then
if (size (prt%name) > 0) name = prt%name(1)
end if
end if
end function field_data_get_name
module subroutine field_data_get_name_array (prt, is_antiparticle, name)
class(field_data_t), intent(in) :: prt
logical, intent(in) :: is_antiparticle
type(string_t), dimension(:), allocatable, intent(inout) :: name
if (allocated (name)) deallocate (name)
if (is_antiparticle) then
if (prt%has_anti) then
allocate (name (size (prt%anti)))
name = prt%anti
else
allocate (name (0))
end if
else
allocate (name (size (prt%name)))
name = prt%name
end if
end subroutine field_data_get_name_array
@ %def field_data_get_name
@ Same for the \TeX\ name.
<<Model data: field data: TBP>>=
procedure :: get_tex_name => field_data_get_tex_name
<<Model data: sub interfaces>>=
elemental module function field_data_get_tex_name &
(prt, is_antiparticle) result (name)
type(string_t) :: name
class(field_data_t), intent(in) :: prt
logical, intent(in) :: is_antiparticle
end function field_data_get_tex_name
<<Model data: procedures>>=
elemental module function field_data_get_tex_name &
(prt, is_antiparticle) result (name)
type(string_t) :: name
class(field_data_t), intent(in) :: prt
logical, intent(in) :: is_antiparticle
if (is_antiparticle) then
if (prt%has_anti) then
name = prt%tex_anti
else
name = prt%tex_name
end if
else
name = prt%tex_name
end if
if (name == "") name = prt%get_name (is_antiparticle)
end function field_data_get_tex_name
@ %def field_data_get_tex_name
@ Check if any of the field names matches the given string.
<<Model data: field data: TBP>>=
procedure, private :: matches_name => field_data_matches_name
<<Model data: sub interfaces>>=
module function field_data_matches_name &
(field, name, is_antiparticle) result (flag)
class(field_data_t), intent(in) :: field
type(string_t), intent(in) :: name
logical, intent(in) :: is_antiparticle
logical :: flag
end function field_data_matches_name
<<Model data: procedures>>=
module function field_data_matches_name &
(field, name, is_antiparticle) result (flag)
class(field_data_t), intent(in) :: field
type(string_t), intent(in) :: name
logical, intent(in) :: is_antiparticle
logical :: flag
if (is_antiparticle) then
if (field%has_anti) then
flag = any (name == field%anti)
else
flag = .false.
end if
else
flag = name == field%longname .or. any (name == field%name)
end if
end function field_data_matches_name
@ %def field_data_matches_name
@ Quantum numbers
<<Model data: field data: TBP>>=
procedure :: get_spin_type => field_data_get_spin_type
procedure :: get_multiplicity => field_data_get_multiplicity
procedure :: get_isospin_type => field_data_get_isospin_type
procedure :: get_charge_type => field_data_get_charge_type
procedure :: get_color_type => field_data_get_color_type
<<Model data: sub interfaces>>=
elemental module function field_data_get_spin_type (prt) result (type)
integer :: type
class(field_data_t), intent(in) :: prt
end function field_data_get_spin_type
elemental module function field_data_get_multiplicity (prt) result (type)
integer :: type
class(field_data_t), intent(in) :: prt
end function field_data_get_multiplicity
elemental module function field_data_get_isospin_type (prt) result (type)
integer :: type
class(field_data_t), intent(in) :: prt
end function field_data_get_isospin_type
elemental module function field_data_get_charge_type (prt) result (type)
integer :: type
class(field_data_t), intent(in) :: prt
end function field_data_get_charge_type
elemental module function field_data_get_color_type (prt) result (type)
integer :: type
class(field_data_t), intent(in) :: prt
end function field_data_get_color_type
<<Model data: procedures>>=
elemental module function field_data_get_spin_type (prt) result (type)
integer :: type
class(field_data_t), intent(in) :: prt
type = prt%spin_type
end function field_data_get_spin_type
elemental module function field_data_get_multiplicity (prt) result (type)
integer :: type
class(field_data_t), intent(in) :: prt
type = prt%multiplicity
end function field_data_get_multiplicity
elemental module function field_data_get_isospin_type (prt) result (type)
integer :: type
class(field_data_t), intent(in) :: prt
type = prt%isospin_type
end function field_data_get_isospin_type
elemental module function field_data_get_charge_type (prt) result (type)
integer :: type
class(field_data_t), intent(in) :: prt
type = prt%charge_type
end function field_data_get_charge_type
elemental module function field_data_get_color_type (prt) result (type)
integer :: type
class(field_data_t), intent(in) :: prt
type = prt%color_type
end function field_data_get_color_type
@ %def field_data_get_spin_type
@ %def field_data_get_multiplicity
@ %def field_data_get_isospin_type
@ %def field_data_get_charge_type
@ %def field_data_get_color_type
@ In the MSSM, neutralinos can have a negative mass. This is
relevant for computing matrix elements. However, within the
\whizard\ main program we are interested only in kinematics, therefore
we return the absolute value of the particle mass. If desired, we can
extract the sign separately.
<<Model data: field data: TBP>>=
procedure :: get_charge => field_data_get_charge
procedure :: get_isospin => field_data_get_isospin
procedure :: get_mass => field_data_get_mass
procedure :: get_mass_sign => field_data_get_mass_sign
procedure :: get_width => field_data_get_width
<<Model data: sub interfaces>>=
elemental module function field_data_get_charge (prt) result (charge)
real(default) :: charge
class(field_data_t), intent(in) :: prt
end function field_data_get_charge
elemental module function field_data_get_isospin (prt) result (isospin)
real(default) :: isospin
class(field_data_t), intent(in) :: prt
end function field_data_get_isospin
elemental module function field_data_get_mass (prt) result (mass)
real(default) :: mass
class(field_data_t), intent(in) :: prt
end function field_data_get_mass
elemental module function field_data_get_mass_sign (prt) result (sgn)
integer :: sgn
class(field_data_t), intent(in) :: prt
end function field_data_get_mass_sign
elemental module function field_data_get_width (prt) result (width)
real(default) :: width
class(field_data_t), intent(in) :: prt
end function field_data_get_width
<<Model data: procedures>>=
elemental module function field_data_get_charge (prt) result (charge)
real(default) :: charge
class(field_data_t), intent(in) :: prt
if (prt%charge_type /= 0) then
charge = real (sign ((abs(prt%charge_type) - 1), &
prt%charge_type), default) / 3
else
charge = 0
end if
end function field_data_get_charge
elemental module function field_data_get_isospin (prt) result (isospin)
real(default) :: isospin
class(field_data_t), intent(in) :: prt
if (prt%isospin_type /= 0) then
isospin = real (sign (abs(prt%isospin_type) - 1, &
prt%isospin_type), default) / 2
else
isospin = 0
end if
end function field_data_get_isospin
elemental module function field_data_get_mass (prt) result (mass)
real(default) :: mass
class(field_data_t), intent(in) :: prt
if (associated (prt%mass_val)) then
mass = abs (prt%mass_val)
else
mass = 0
end if
end function field_data_get_mass
elemental module function field_data_get_mass_sign (prt) result (sgn)
integer :: sgn
class(field_data_t), intent(in) :: prt
if (associated (prt%mass_val)) then
sgn = sign (1._default, prt%mass_val)
else
sgn = 0
end if
end function field_data_get_mass_sign
elemental module function field_data_get_width (prt) result (width)
real(default) :: width
class(field_data_t), intent(in) :: prt
if (associated (prt%width_val)) then
width = prt%width_val
else
width = 0
end if
end function field_data_get_width
@ %def field_data_get_charge field_data_get_isospin
@ %def field_data_get_mass field_data_get_mass_sign
@ %def field_data_get_width
@ Find the [[model]] containing the [[PDG]] given two model files.
<<Model data: public>>=
public :: find_model
<<Model data: sub interfaces>>=
module subroutine find_model (model, PDG, model_A, model_B)
class(model_data_t), pointer, intent(out) :: model
integer, intent(in) :: PDG
class(model_data_t), intent(in), target :: model_A, model_B
end subroutine find_model
<<Model data: procedures>>=
module subroutine find_model (model, PDG, model_A, model_B)
class(model_data_t), pointer, intent(out) :: model
integer, intent(in) :: PDG
class(model_data_t), intent(in), target :: model_A, model_B
character(len=10) :: buffer
if (model_A%test_field (PDG)) then
model => model_A
else if (model_B%test_field (PDG)) then
model => model_B
else
call model_A%write ()
call model_B%write ()
write (buffer, "(I10)") PDG
call msg_fatal ("Parton " // buffer // &
" not found in the given model files")
end if
end subroutine find_model
@ %def find_model
@
\subsection{Vertex data}
The vertex object contains an array of particle-data pointers, for
which we need a separate type. (We could use the flavor type defined
in another module.)
The program does not (yet?) make use of vertex definitions, so they
are not stored here.
<<Model data: types>>=
type :: field_data_p
type(field_data_t), pointer :: p => null ()
end type field_data_p
@ %def field_data_p
<<Model data: types>>=
type :: vertex_t
private
logical :: trilinear
integer, dimension(:), allocatable :: pdg
type(field_data_p), dimension(:), allocatable :: prt
contains
<<Model data: vertex: TBP>>
end type vertex_t
@ %def vertex_t
<<Model data: vertex: TBP>>=
procedure :: write => vertex_write
<<Model data: sub interfaces>>=
module subroutine vertex_write (vtx, unit)
class(vertex_t), intent(in) :: vtx
integer, intent(in), optional :: unit
end subroutine vertex_write
<<Model data: procedures>>=
module subroutine vertex_write (vtx, unit)
class(vertex_t), intent(in) :: vtx
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
write (u, "(3x,A)", advance="no") "vertex"
do i = 1, size (vtx%prt)
if (associated (vtx%prt(i)%p)) then
write (u, "(1x,A)", advance="no") &
'"' // char (vtx%prt(i)%p%get_name (vtx%pdg(i) < 0)) &
// '"'
else
write (u, "(1x,I7)", advance="no") vtx%pdg(i)
end if
end do
write (u, *)
end subroutine vertex_write
@ %def vertex_write
@ Initialize using PDG codes. The model is used for finding particle
data pointers associated with the pdg codes.
<<Model data: vertex: TBP>>=
procedure :: init => vertex_init
<<Model data: sub interfaces>>=
module subroutine vertex_init (vtx, pdg, model)
class(vertex_t), intent(out) :: vtx
integer, dimension(:), intent(in) :: pdg
type(model_data_t), intent(in), target, optional :: model
end subroutine vertex_init
<<Model data: procedures>>=
module subroutine vertex_init (vtx, pdg, model)
class(vertex_t), intent(out) :: vtx
integer, dimension(:), intent(in) :: pdg
type(model_data_t), intent(in), target, optional :: model
integer :: i
allocate (vtx%pdg (size (pdg)))
allocate (vtx%prt (size (pdg)))
vtx%trilinear = size (pdg) == 3
vtx%pdg = pdg
if (present (model)) then
do i = 1, size (pdg)
vtx%prt(i)%p => model%get_field_ptr (pdg(i))
end do
end if
end subroutine vertex_init
@ %def vertex_init
@ Copy vertex: we must reassign the field-data pointer to a new model.
<<Model data: vertex: TBP>>=
procedure :: copy_from => vertex_copy_from
<<Model data: sub interfaces>>=
module subroutine vertex_copy_from (vtx, old_vtx, new_model)
class(vertex_t), intent(out) :: vtx
class(vertex_t), intent(in) :: old_vtx
type(model_data_t), intent(in), target, optional :: new_model
end subroutine vertex_copy_from
<<Model data: procedures>>=
module subroutine vertex_copy_from (vtx, old_vtx, new_model)
class(vertex_t), intent(out) :: vtx
class(vertex_t), intent(in) :: old_vtx
type(model_data_t), intent(in), target, optional :: new_model
call vtx%init (old_vtx%pdg, new_model)
end subroutine vertex_copy_from
@ %def vertex_copy_from
@ Single-particle lookup: Given a particle code, we return matching
codes if present, otherwise zero. Actually, we return the
antiparticles of the matching codes, as appropriate for computing
splittings.
<<Model data: vertex: TBP>>=
procedure :: get_match => vertex_get_match
<<Model data: sub interfaces>>=
module subroutine vertex_get_match (vtx, pdg1, pdg2)
class(vertex_t), intent(in) :: vtx
integer, intent(in) :: pdg1
integer, dimension(:), allocatable, intent(out) :: pdg2
end subroutine vertex_get_match
<<Model data: procedures>>=
module subroutine vertex_get_match (vtx, pdg1, pdg2)
class(vertex_t), intent(in) :: vtx
integer, intent(in) :: pdg1
integer, dimension(:), allocatable, intent(out) :: pdg2
integer :: i, j
do i = 1, size (vtx%pdg)
if (vtx%pdg(i) == pdg1) then
allocate (pdg2 (size (vtx%pdg) - 1))
do j = 1, i-1
pdg2(j) = anti (j)
end do
do j = i, size (pdg2)
pdg2(j) = anti (j+1)
end do
exit
end if
end do
contains
function anti (i) result (pdg)
integer, intent(in) :: i
integer :: pdg
if (vtx%prt(i)%p%has_antiparticle ()) then
pdg = - vtx%pdg(i)
else
pdg = vtx%pdg(i)
end if
end function anti
end subroutine vertex_get_match
@ %def vertex_get_match
@ To access this from the outside, we create an iterator. The iterator has
the sole purpose of returning the matching particles for a given array of PDG
codes.
<<Model data: public>>=
public :: vertex_iterator_t
<<Model data: types>>=
type :: vertex_iterator_t
private
class(model_data_t), pointer :: model => null ()
integer, dimension(:), allocatable :: pdg
integer :: vertex_index = 0
integer :: pdg_index = 0
logical :: save_pdg_index
contains
procedure :: init => vertex_iterator_init
procedure :: get_next_match => vertex_iterator_get_next_match
end type vertex_iterator_t
@ %def vertex_iterator_t
@ We initialize the iterator for a particular model with the [[pdg]] index of
the particle we are looking at.
<<Model data: sub interfaces>>=
module subroutine vertex_iterator_init (it, model, pdg, save_pdg_index)
class(vertex_iterator_t), intent(out) :: it
class(model_data_t), intent(in), target :: model
integer, dimension(:), intent(in) :: pdg
logical, intent(in) :: save_pdg_index
end subroutine vertex_iterator_init
module subroutine vertex_iterator_get_next_match (it, pdg_match)
class(vertex_iterator_t), intent(inout) :: it
integer, dimension(:), allocatable, intent(out) :: pdg_match
end subroutine vertex_iterator_get_next_match
<<Model data: procedures>>=
module subroutine vertex_iterator_init (it, model, pdg, save_pdg_index)
class(vertex_iterator_t), intent(out) :: it
class(model_data_t), intent(in), target :: model
integer, dimension(:), intent(in) :: pdg
logical, intent(in) :: save_pdg_index
it%model => model
allocate (it%pdg (size (pdg)), source = pdg)
it%save_pdg_index = save_pdg_index
end subroutine vertex_iterator_init
module subroutine vertex_iterator_get_next_match (it, pdg_match)
class(vertex_iterator_t), intent(inout) :: it
integer, dimension(:), allocatable, intent(out) :: pdg_match
integer :: i, j
do i = it%vertex_index + 1, size (it%model%vtx)
do j = it%pdg_index + 1, size (it%pdg)
call it%model%vtx(i)%get_match (it%pdg(j), pdg_match)
if (it%save_pdg_index) then
if (allocated (pdg_match) .and. j < size (it%pdg)) then
it%pdg_index = j
return
else if (allocated (pdg_match) .and. j == size (it%pdg)) then
it%vertex_index = i
it%pdg_index = 0
return
end if
else if (allocated (pdg_match)) then
it%vertex_index = i
return
end if
end do
end do
it%vertex_index = 0
it%pdg_index = 0
end subroutine vertex_iterator_get_next_match
@ %def vertex_iterator_get_next_match
@
\subsection{Vertex lookup table}
The vertex lookup table is a hash table: given two particle codes, we
check which codes are allowed for the third one.
The size of the hash table should be large enough that collisions are
rare. We first select a size based on the number of vertices
(multiplied by six because all permutations count), with some margin,
and then choose the smallest integer power of two larger than this.
<<Model data: parameters>>=
integer, parameter :: VERTEX_TABLE_SCALE_FACTOR = 60
@ %def VERTEX_TABLE_SCALE_FACTOR
<<Model data: procedures>>=
function vertex_table_size (n_vtx) result (n)
integer(i32) :: n
integer, intent(in) :: n_vtx
integer :: i, s
s = VERTEX_TABLE_SCALE_FACTOR * n_vtx
n = 1
do i = 1, 31
n = ishft (n, 1)
s = ishft (s,-1)
if (s == 0) exit
end do
end function vertex_table_size
@ %def vertex_table_size
@ The specific hash function takes two particle codes (arbitrary
integers) and returns a 32-bit integer. It makes use of the universal
function [[hash]] which operates on a byte array.
<<Model data: procedures>>=
function hash2 (pdg1, pdg2)
integer(i32) :: hash2
integer, intent(in) :: pdg1, pdg2
integer(i8), dimension(1) :: mold
hash2 = hash (transfer ([pdg1, pdg2], mold))
end function hash2
@ %def hash2
@ Each entry in the vertex table stores the two particle codes and an
array of possibilities for the third code.
<<Model data: types>>=
type :: vertex_table_entry_t
private
integer :: pdg1 = 0, pdg2 = 0
integer :: n = 0
integer, dimension(:), allocatable :: pdg3
end type vertex_table_entry_t
@ %def vertex_table_entry_t
@ The vertex table:
<<Model data: types>>=
type :: vertex_table_t
type(vertex_table_entry_t), dimension(:), allocatable :: entry
integer :: n_collisions = 0
integer(i32) :: mask
contains
<<Model data: vertex table: TBP>>
end type vertex_table_t
@ %def vertex_table_t
@ Output.
<<Model data: vertex table: TBP>>=
procedure :: write => vertex_table_write
<<Model data: sub interfaces>>=
module subroutine vertex_table_write (vt, unit)
class(vertex_table_t), intent(in) :: vt
integer, intent(in), optional :: unit
end subroutine vertex_table_write
<<Model data: procedures>>=
module subroutine vertex_table_write (vt, unit)
class(vertex_table_t), intent(in) :: vt
integer, intent(in), optional :: unit
integer :: u, i
character(9) :: size_pdg3
u = given_output_unit (unit)
write (u, "(A)") "vertex hash table:"
write (u, "(A,I7)") " size = ", size (vt%entry)
write (u, "(A,I7)") " used = ", count (vt%entry%n /= 0)
write (u, "(A,I7)") " coll = ", vt%n_collisions
do i = lbound (vt%entry, 1), ubound (vt%entry, 1)
if (vt%entry(i)%n /= 0) then
write (size_pdg3, "(I7)") size (vt%entry(i)%pdg3)
write (u, "(A,1x,I7,1x,A,2(1x,I7),A," // &
size_pdg3 // "(1x,I7))") &
" ", i, ":", vt%entry(i)%pdg1, &
vt%entry(i)%pdg2, "->", vt%entry(i)%pdg3
end if
end do
end subroutine vertex_table_write
@ %def vertex_table_write
@ Initializing the vertex table: This is done in two passes. First,
we scan all permutations for all vertices and count the number of
entries in each bucket of the hashtable. Then, the buckets are
allocated accordingly and filled.
Collision resolution is done by just incrementing the hash value until
an empty bucket is found. The vertex table size is fixed, since we
know from the beginning the number of entries.
<<Model data: vertex table: TBP>>=
procedure :: init => vertex_table_init
<<Model data: sub interfaces>>=
module subroutine vertex_table_init (vt, prt, vtx)
class(vertex_table_t), intent(out) :: vt
type(field_data_t), dimension(:), intent(in) :: prt
type(vertex_t), dimension(:), intent(in) :: vtx
end subroutine vertex_table_init
<<Model data: procedures>>=
module subroutine vertex_table_init (vt, prt, vtx)
class(vertex_table_t), intent(out) :: vt
type(field_data_t), dimension(:), intent(in) :: prt
type(vertex_t), dimension(:), intent(in) :: vtx
integer :: n_vtx, vt_size, i, p1, p2, p3
integer, dimension(3) :: p
n_vtx = size (vtx)
vt_size = vertex_table_size (count (vtx%trilinear))
vt%mask = vt_size - 1
allocate (vt%entry (0:vt_size-1))
do i = 1, n_vtx
if (vtx(i)%trilinear) then
p = vtx(i)%pdg
p1 = p(1); p2 = p(2)
call create (hash2 (p1, p2))
if (p(2) /= p(3)) then
p2 = p(3)
call create (hash2 (p1, p2))
end if
if (p(1) /= p(2)) then
p1 = p(2); p2 = p(1)
call create (hash2 (p1, p2))
if (p(1) /= p(3)) then
p2 = p(3)
call create (hash2 (p1, p2))
end if
end if
if (p(1) /= p(3)) then
p1 = p(3); p2 = p(1)
call create (hash2 (p1, p2))
if (p(1) /= p(2)) then
p2 = p(2)
call create (hash2 (p1, p2))
end if
end if
end if
end do
do i = 0, vt_size - 1
allocate (vt%entry(i)%pdg3 (vt%entry(i)%n))
end do
vt%entry%n = 0
do i = 1, n_vtx
if (vtx(i)%trilinear) then
p = vtx(i)%pdg
p1 = p(1); p2 = p(2); p3 = p(3)
call register (hash2 (p1, p2))
if (p(2) /= p(3)) then
p2 = p(3); p3 = p(2)
call register (hash2 (p1, p2))
end if
if (p(1) /= p(2)) then
p1 = p(2); p2 = p(1); p3 = p(3)
call register (hash2 (p1, p2))
if (p(1) /= p(3)) then
p2 = p(3); p3 = p(1)
call register (hash2 (p1, p2))
end if
end if
if (p(1) /= p(3)) then
p1 = p(3); p2 = p(1); p3 = p(2)
call register (hash2 (p1, p2))
if (p(1) /= p(2)) then
p2 = p(2); p3 = p(1)
call register (hash2 (p1, p2))
end if
end if
end if
end do
contains
recursive subroutine create (hashval)
integer(i32), intent(in) :: hashval
integer :: h
h = iand (hashval, vt%mask)
if (vt%entry(h)%n == 0) then
vt%entry(h)%pdg1 = p1
vt%entry(h)%pdg2 = p2
vt%entry(h)%n = 1
else if (vt%entry(h)%pdg1 == p1 .and. vt%entry(h)%pdg2 == p2) then
vt%entry(h)%n = vt%entry(h)%n + 1
else
vt%n_collisions = vt%n_collisions + 1
call create (hashval + 1)
end if
end subroutine create
recursive subroutine register (hashval)
integer(i32), intent(in) :: hashval
integer :: h
h = iand (hashval, vt%mask)
if (vt%entry(h)%pdg1 == p1 .and. vt%entry(h)%pdg2 == p2) then
vt%entry(h)%n = vt%entry(h)%n + 1
vt%entry(h)%pdg3(vt%entry(h)%n) = p3
else
call register (hashval + 1)
end if
end subroutine register
end subroutine vertex_table_init
@ %def vertex_table_init
@ Return the array of particle codes that match the given pair.
<<Model data: vertex table: TBP>>=
procedure :: match => vertex_table_match
<<Model data: sub interfaces>>=
module subroutine vertex_table_match (vt, pdg1, pdg2, pdg3)
class(vertex_table_t), intent(in) :: vt
integer, intent(in) :: pdg1, pdg2
integer, dimension(:), allocatable, intent(out) :: pdg3
end subroutine vertex_table_match
<<Model data: procedures>>=
module subroutine vertex_table_match (vt, pdg1, pdg2, pdg3)
class(vertex_table_t), intent(in) :: vt
integer, intent(in) :: pdg1, pdg2
integer, dimension(:), allocatable, intent(out) :: pdg3
call match (hash2 (pdg1, pdg2))
contains
recursive subroutine match (hashval)
integer(i32), intent(in) :: hashval
integer :: h
h = iand (hashval, vt%mask)
if (vt%entry(h)%n == 0) then
allocate (pdg3 (0))
else if (vt%entry(h)%pdg1 == pdg1 .and. vt%entry(h)%pdg2 == pdg2) then
allocate (pdg3 (size (vt%entry(h)%pdg3)))
pdg3 = vt%entry(h)%pdg3
else
call match (hashval + 1)
end if
end subroutine match
end subroutine vertex_table_match
@ %def vertex_table_match
@ Return true if the triplet is represented as a vertex.
<<Model data: vertex table: TBP>>=
procedure :: check => vertex_table_check
<<Model data: sub interfaces>>=
module function vertex_table_check (vt, pdg1, pdg2, pdg3) result (flag)
class(vertex_table_t), intent(in) :: vt
integer, intent(in) :: pdg1, pdg2, pdg3
logical :: flag
end function vertex_table_check
<<Model data: procedures>>=
module function vertex_table_check (vt, pdg1, pdg2, pdg3) result (flag)
class(vertex_table_t), intent(in) :: vt
integer, intent(in) :: pdg1, pdg2, pdg3
logical :: flag
flag = check (hash2 (pdg1, pdg2))
contains
recursive function check (hashval) result (flag)
integer(i32), intent(in) :: hashval
integer :: h
logical :: flag
h = iand (hashval, vt%mask)
if (vt%entry(h)%n == 0) then
flag = .false.
else if (vt%entry(h)%pdg1 == pdg1 .and. vt%entry(h)%pdg2 == pdg2) then
flag = any (vt%entry(h)%pdg3 == pdg3)
else
flag = check (hashval + 1)
end if
end function check
end function vertex_table_check
@ %def vertex_table_check
@
\subsection{Model Data Record}
This type collects the model data as defined above.
We deliberately implement the parameter arrays as pointer arrays. We
thus avoid keeping track of TARGET attributes.
The [[scheme]] identifier provides meta information. It doesn't give the
client code an extra parameter, but it tells something about the
interpretation of the parameters. If the scheme ID is left as default (zero),
it is ignored.
<<Model data: public>>=
public :: model_data_t
<<Model data: types>>=
type :: model_data_t
private
type(string_t) :: name
integer :: scheme = 0
type(modelpar_real_t), dimension(:), pointer :: par_real => null ()
type(modelpar_complex_t), dimension(:), pointer :: par_complex => null ()
type(field_data_t), dimension(:), allocatable :: field
type(vertex_t), dimension(:), allocatable :: vtx
type(vertex_table_t) :: vt
contains
<<Model data: model data: TBP>>
end type model_data_t
@ %def model_data_t
@ Finalizer, deallocate pointer arrays.
<<Model data: model data: TBP>>=
procedure :: final => model_data_final
<<Model data: sub interfaces>>=
module subroutine model_data_final (model)
class(model_data_t), intent(inout) :: model
end subroutine model_data_final
<<Model data: procedures>>=
module subroutine model_data_final (model)
class(model_data_t), intent(inout) :: model
if (associated (model%par_real)) then
deallocate (model%par_real)
end if
if (associated (model%par_complex)) then
deallocate (model%par_complex)
end if
end subroutine model_data_final
@ %def model_data_final
@ Output. The signature matches the signature of the high-level
[[model_write]] procedure, so some of the options don't actually apply.
<<Model data: model data: TBP>>=
procedure :: write => model_data_write
<<Model data: sub interfaces>>=
module subroutine model_data_write (model, unit, verbose, &
show_md5sum, show_variables, show_parameters, &
show_particles, show_vertices, show_scheme)
class(model_data_t), intent(in) :: model
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
logical, intent(in), optional :: show_md5sum
logical, intent(in), optional :: show_variables
logical, intent(in), optional :: show_parameters
logical, intent(in), optional :: show_particles
logical, intent(in), optional :: show_vertices
logical, intent(in), optional :: show_scheme
end subroutine model_data_write
<<Model data: procedures>>=
module subroutine model_data_write (model, unit, verbose, &
show_md5sum, show_variables, show_parameters, &
show_particles, show_vertices, show_scheme)
class(model_data_t), intent(in) :: model
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
logical, intent(in), optional :: show_md5sum
logical, intent(in), optional :: show_variables
logical, intent(in), optional :: show_parameters
logical, intent(in), optional :: show_particles
logical, intent(in), optional :: show_vertices
logical, intent(in), optional :: show_scheme
logical :: show_sch, show_par, show_prt, show_vtx
integer :: u, i
u = given_output_unit (unit)
show_sch = .false.; if (present (show_scheme)) &
show_sch = show_scheme
show_par = .true.; if (present (show_parameters)) &
show_par = show_parameters
show_prt = .true.; if (present (show_particles)) &
show_prt = show_particles
show_vtx = .true.; if (present (show_vertices)) &
show_vtx = show_vertices
if (show_sch) then
write (u, "(3x,A,1X,I0)") "scheme =", model%scheme
end if
if (show_par) then
do i = 1, size (model%par_real)
call model%par_real(i)%write (u)
write (u, "(A)")
end do
do i = 1, size (model%par_complex)
call model%par_complex(i)%write (u)
write (u, "(A)")
end do
end if
if (show_prt) then
write (u, "(A)")
call model%write_fields (u)
end if
if (show_vtx) then
write (u, "(A)")
call model%write_vertices (u, verbose)
end if
end subroutine model_data_write
@ %def model_data_write
@ Initialize, allocating pointer arrays. The second version makes a
deep copy.
<<Model data: model data: TBP>>=
generic :: init => model_data_init
procedure, private :: model_data_init
<<Model data: sub interfaces>>=
module subroutine model_data_init (model, name, &
n_par_real, n_par_complex, n_field, n_vtx)
class(model_data_t), intent(out) :: model
type(string_t), intent(in) :: name
integer, intent(in) :: n_par_real, n_par_complex
integer, intent(in) :: n_field
integer, intent(in) :: n_vtx
end subroutine model_data_init
<<Model data: procedures>>=
module subroutine model_data_init (model, name, &
n_par_real, n_par_complex, n_field, n_vtx)
class(model_data_t), intent(out) :: model
type(string_t), intent(in) :: name
integer, intent(in) :: n_par_real, n_par_complex
integer, intent(in) :: n_field
integer, intent(in) :: n_vtx
model%name = name
allocate (model%par_real (n_par_real))
allocate (model%par_complex (n_par_complex))
allocate (model%field (n_field))
allocate (model%vtx (n_vtx))
end subroutine model_data_init
@ %def model_data_init
@ Set the scheme ID.
<<Model data: model data: TBP>>=
procedure :: set_scheme_num => model_data_set_scheme_num
<<Model data: sub interfaces>>=
module subroutine model_data_set_scheme_num (model, scheme)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: scheme
end subroutine model_data_set_scheme_num
<<Model data: procedures>>=
module subroutine model_data_set_scheme_num (model, scheme)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: scheme
model%scheme = scheme
end subroutine model_data_set_scheme_num
@ %def model_data_set_scheme_num
@ Complete model data initialization.
<<Model data: model data: TBP>>=
procedure :: freeze_fields => model_data_freeze_fields
<<Model data: sub interfaces>>=
module subroutine model_data_freeze_fields (model)
class(model_data_t), intent(inout) :: model
end subroutine model_data_freeze_fields
<<Model data: procedures>>=
module subroutine model_data_freeze_fields (model)
class(model_data_t), intent(inout) :: model
call model%field%freeze ()
end subroutine model_data_freeze_fields
@ %def model_data_freeze
@ Deep copy. The new model should already be initialized, so we do
not allocate memory.
<<Model data: model data: TBP>>=
procedure :: copy_from => model_data_copy
<<Model data: sub interfaces>>=
module subroutine model_data_copy (model, src)
class(model_data_t), intent(inout), target :: model
class(model_data_t), intent(in), target :: src
end subroutine model_data_copy
<<Model data: procedures>>=
module subroutine model_data_copy (model, src)
class(model_data_t), intent(inout), target :: model
class(model_data_t), intent(in), target :: src
class(modelpar_data_t), pointer :: data, src_data
integer :: i
model%scheme = src%scheme
model%par_real = src%par_real
model%par_complex = src%par_complex
do i = 1, size (src%field)
associate (field => model%field(i), src_field => src%field(i))
call field%init (src_field%get_longname (), src_field%get_pdg ())
call field%copy_from (src_field)
src_data => src_field%mass_data
if (associated (src_data)) then
data => model%get_par_data_ptr (src_data%get_name ())
call field%set (mass_data = data)
end if
src_data => src_field%width_data
if (associated (src_data)) then
data => model%get_par_data_ptr (src_data%get_name ())
call field%set (width_data = data)
end if
call field%set_multiplicity ()
end associate
end do
do i = 1, size (src%vtx)
call model%vtx(i)%copy_from (src%vtx(i), model)
end do
call model%freeze_vertices ()
end subroutine model_data_copy
@ %def model_data_copy
@ Return the model name and numeric scheme.
<<Model data: model data: TBP>>=
procedure :: get_name => model_data_get_name
procedure :: get_scheme_num => model_data_get_scheme_num
<<Model data: sub interfaces>>=
module function model_data_get_name (model) result (name)
class(model_data_t), intent(in) :: model
type(string_t) :: name
end function model_data_get_name
module function model_data_get_scheme_num (model) result (scheme)
class(model_data_t), intent(in) :: model
integer :: scheme
end function model_data_get_scheme_num
<<Model data: procedures>>=
module function model_data_get_name (model) result (name)
class(model_data_t), intent(in) :: model
type(string_t) :: name
name = model%name
end function model_data_get_name
module function model_data_get_scheme_num (model) result (scheme)
class(model_data_t), intent(in) :: model
integer :: scheme
scheme = model%scheme
end function model_data_get_scheme_num
@ %def model_data_get_name
@ %def model_data_get_scheme
@ Retrieve a MD5 sum for the current model parameter values and
decay/polarization settings. This is
done by writing them to a temporary file, using a standard format. If the
model scheme is nonzero, it is also written.
<<Model data: model data: TBP>>=
procedure :: get_parameters_md5sum => model_data_get_parameters_md5sum
<<Model data: sub interfaces>>=
module function model_data_get_parameters_md5sum (model) result (par_md5sum)
character(32) :: par_md5sum
class(model_data_t), intent(in) :: model
end function model_data_get_parameters_md5sum
<<Model data: procedures>>=
module function model_data_get_parameters_md5sum (model) result (par_md5sum)
character(32) :: par_md5sum
class(model_data_t), intent(in) :: model
real(default), dimension(:), allocatable :: par
type(field_data_t), pointer :: field
integer :: unit, i
allocate (par (model%get_n_real ()))
call model%real_parameters_to_array (par)
unit = free_unit ()
open (unit, status="scratch", action="readwrite")
if (model%scheme /= 0) write (unit, "(I0)") model%scheme
write (unit, "(" // FMT_19 // ")") par
do i = 1, model%get_n_field ()
field => model%get_field_ptr_by_index (i)
if (.not. field%is_stable (.false.) .or. .not. field%is_stable (.true.) &
.or. field%is_polarized (.false.) .or. field%is_polarized (.true.))&
then
write (unit, "(3x,A)") char (field%get_longname ())
call field%write_decays (unit)
end if
end do
rewind (unit)
par_md5sum = md5sum (unit)
close (unit)
end function model_data_get_parameters_md5sum
@ %def model_get_parameters_md5sum
@ Return the MD5 sum. This is a placeholder, to be overwritten
for the complete model definition.
<<Model data: model data: TBP>>=
procedure :: get_md5sum => model_data_get_md5sum
<<Model data: sub interfaces>>=
module function model_data_get_md5sum (model) result (md5sum)
class(model_data_t), intent(in) :: model
character(32) :: md5sum
end function model_data_get_md5sum
<<Model data: procedures>>=
module function model_data_get_md5sum (model) result (md5sum)
class(model_data_t), intent(in) :: model
character(32) :: md5sum
md5sum = model%get_parameters_md5sum ()
end function model_data_get_md5sum
@ %def model_data_get_md5sum
@ Initialize a real or complex parameter.
<<Model data: model data: TBP>>=
generic :: init_par => model_data_init_par_real, model_data_init_par_complex
procedure, private :: model_data_init_par_real
procedure, private :: model_data_init_par_complex
<<Model data: sub interfaces>>=
module subroutine model_data_init_par_real (model, i, name, value)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: i
type(string_t), intent(in) :: name
real(default), intent(in) :: value
end subroutine model_data_init_par_real
module subroutine model_data_init_par_complex (model, i, name, value)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: i
type(string_t), intent(in) :: name
complex(default), intent(in) :: value
end subroutine model_data_init_par_complex
<<Model data: procedures>>=
module subroutine model_data_init_par_real (model, i, name, value)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: i
type(string_t), intent(in) :: name
real(default), intent(in) :: value
call model%par_real(i)%init (name, value)
end subroutine model_data_init_par_real
module subroutine model_data_init_par_complex (model, i, name, value)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: i
type(string_t), intent(in) :: name
complex(default), intent(in) :: value
call model%par_complex(i)%init (name, value)
end subroutine model_data_init_par_complex
@ %def model_data_init_par_real model_data_init_par_complex
@ After initialization, return size of parameter array.
<<Model data: model data: TBP>>=
procedure :: get_n_real => model_data_get_n_real
procedure :: get_n_complex => model_data_get_n_complex
<<Model data: sub interfaces>>=
module function model_data_get_n_real (model) result (n)
class(model_data_t), intent(in) :: model
integer :: n
end function model_data_get_n_real
module function model_data_get_n_complex (model) result (n)
class(model_data_t), intent(in) :: model
integer :: n
end function model_data_get_n_complex
<<Model data: procedures>>=
module function model_data_get_n_real (model) result (n)
class(model_data_t), intent(in) :: model
integer :: n
n = size (model%par_real)
end function model_data_get_n_real
module function model_data_get_n_complex (model) result (n)
class(model_data_t), intent(in) :: model
integer :: n
n = size (model%par_complex)
end function model_data_get_n_complex
@ %def model_data_get_n_real
@ %def model_data_get_n_complex
@ After initialization, extract the whole parameter array.
<<Model data: model data: TBP>>=
procedure :: real_parameters_to_array &
=> model_data_real_par_to_array
procedure :: complex_parameters_to_array &
=> model_data_complex_par_to_array
<<Model data: sub interfaces>>=
module subroutine model_data_real_par_to_array (model, array)
class(model_data_t), intent(in) :: model
real(default), dimension(:), intent(inout) :: array
end subroutine model_data_real_par_to_array
module subroutine model_data_complex_par_to_array (model, array)
class(model_data_t), intent(in) :: model
complex(default), dimension(:), intent(inout) :: array
end subroutine model_data_complex_par_to_array
<<Model data: procedures>>=
module subroutine model_data_real_par_to_array (model, array)
class(model_data_t), intent(in) :: model
real(default), dimension(:), intent(inout) :: array
array = model%par_real%get_real ()
end subroutine model_data_real_par_to_array
module subroutine model_data_complex_par_to_array (model, array)
class(model_data_t), intent(in) :: model
complex(default), dimension(:), intent(inout) :: array
array = model%par_complex%get_complex ()
end subroutine model_data_complex_par_to_array
@ %def model_data_real_par_to_array
@ %def model_data_complex_par_to_array
@ After initialization, set the whole parameter array.
<<Model data: model data: TBP>>=
procedure :: real_parameters_from_array &
=> model_data_real_par_from_array
procedure :: complex_parameters_from_array &
=> model_data_complex_par_from_array
<<Model data: sub interfaces>>=
module subroutine model_data_real_par_from_array (model, array)
class(model_data_t), intent(inout) :: model
real(default), dimension(:), intent(in) :: array
end subroutine model_data_real_par_from_array
module subroutine model_data_complex_par_from_array (model, array)
class(model_data_t), intent(inout) :: model
complex(default), dimension(:), intent(in) :: array
end subroutine model_data_complex_par_from_array
<<Model data: procedures>>=
module subroutine model_data_real_par_from_array (model, array)
class(model_data_t), intent(inout) :: model
real(default), dimension(:), intent(in) :: array
model%par_real = array
end subroutine model_data_real_par_from_array
module subroutine model_data_complex_par_from_array (model, array)
class(model_data_t), intent(inout) :: model
complex(default), dimension(:), intent(in) :: array
model%par_complex = array
end subroutine model_data_complex_par_from_array
@ %def model_data_real_par_from_array
@ %def model_data_complex_par_from_array
@ Analogous, for a C parameter array.
<<Model data: model data: TBP>>=
procedure :: real_parameters_to_c_array &
=> model_data_real_par_to_c_array
<<Model data: sub interfaces>>=
module subroutine model_data_real_par_to_c_array (model, array)
class(model_data_t), intent(in) :: model
real(c_default_float), dimension(:), intent(inout) :: array
end subroutine model_data_real_par_to_c_array
<<Model data: procedures>>=
module subroutine model_data_real_par_to_c_array (model, array)
class(model_data_t), intent(in) :: model
real(c_default_float), dimension(:), intent(inout) :: array
array = model%par_real%get_real ()
end subroutine model_data_real_par_to_c_array
@ %def model_data_real_par_to_c_array
@ After initialization, set the whole parameter array.
<<Model data: model data: TBP>>=
procedure :: real_parameters_from_c_array &
=> model_data_real_par_from_c_array
<<Model data: sub interfaces>>=
module subroutine model_data_real_par_from_c_array (model, array)
class(model_data_t), intent(inout) :: model
real(c_default_float), dimension(:), intent(in) :: array
end subroutine model_data_real_par_from_c_array
<<Model data: procedures>>=
module subroutine model_data_real_par_from_c_array (model, array)
class(model_data_t), intent(inout) :: model
real(c_default_float), dimension(:), intent(in) :: array
model%par_real = real (array, default)
end subroutine model_data_real_par_from_c_array
@ %def model_data_real_par_from_c_array
@ After initialization, get pointer to a real or complex parameter,
directly by index.
<<Model data: model data: TBP>>=
procedure :: get_par_real_ptr => model_data_get_par_real_ptr_index
procedure :: get_par_complex_ptr => model_data_get_par_complex_ptr_index
<<Model data: sub interfaces>>=
module function model_data_get_par_real_ptr_index (model, i) result (ptr)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: i
class(modelpar_data_t), pointer :: ptr
end function model_data_get_par_real_ptr_index
module function model_data_get_par_complex_ptr_index (model, i) result (ptr)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: i
class(modelpar_data_t), pointer :: ptr
end function model_data_get_par_complex_ptr_index
<<Model data: procedures>>=
module function model_data_get_par_real_ptr_index (model, i) result (ptr)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: i
class(modelpar_data_t), pointer :: ptr
ptr => model%par_real(i)
end function model_data_get_par_real_ptr_index
module function model_data_get_par_complex_ptr_index (model, i) result (ptr)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: i
class(modelpar_data_t), pointer :: ptr
ptr => model%par_complex(i)
end function model_data_get_par_complex_ptr_index
@ %def model_data_get_par_real_ptr model_data_get_par_complex_ptr
@ After initialization, get pointer to a parameter by name.
<<Model data: model data: TBP>>=
procedure :: get_par_data_ptr => model_data_get_par_data_ptr_name
<<Model data: sub interfaces>>=
module function model_data_get_par_data_ptr_name (model, name) result (ptr)
class(model_data_t), intent(in) :: model
type(string_t), intent(in) :: name
class(modelpar_data_t), pointer :: ptr
end function model_data_get_par_data_ptr_name
<<Model data: procedures>>=
module function model_data_get_par_data_ptr_name (model, name) result (ptr)
class(model_data_t), intent(in) :: model
type(string_t), intent(in) :: name
class(modelpar_data_t), pointer :: ptr
integer :: i
do i = 1, size (model%par_real)
if (model%par_real(i)%name == name) then
ptr => model%par_real(i)
return
end if
end do
do i = 1, size (model%par_complex)
if (model%par_complex(i)%name == name) then
ptr => model%par_complex(i)
return
end if
end do
ptr => null ()
end function model_data_get_par_data_ptr_name
@ %def model_data_get_par_data_ptr
@ Return the value by name. Again, type conversion is allowed.
<<Model data: model data: TBP>>=
procedure :: get_real => model_data_get_par_real_value
procedure :: get_complex => model_data_get_par_complex_value
<<Model data: sub interfaces>>=
module function model_data_get_par_real_value (model, name) result (value)
class(model_data_t), intent(in) :: model
type(string_t), intent(in) :: name
real(default) :: value
end function model_data_get_par_real_value
module function model_data_get_par_complex_value &
(model, name) result (value)
class(model_data_t), intent(in) :: model
type(string_t), intent(in) :: name
complex(default) :: value
end function model_data_get_par_complex_value
<<Model data: procedures>>=
module function model_data_get_par_real_value (model, name) result (value)
class(model_data_t), intent(in) :: model
type(string_t), intent(in) :: name
class(modelpar_data_t), pointer :: par
real(default) :: value
par => model%get_par_data_ptr (name)
value = par%get_real ()
end function model_data_get_par_real_value
module function model_data_get_par_complex_value (model, name) result (value)
class(model_data_t), intent(in) :: model
type(string_t), intent(in) :: name
class(modelpar_data_t), pointer :: par
complex(default) :: value
par => model%get_par_data_ptr (name)
value = par%get_complex ()
end function model_data_get_par_complex_value
@ %def model_data_get_real
@ %def model_data_get_complex
@ Modify a real or complex parameter.
<<Model data: model data: TBP>>=
generic :: set_par => model_data_set_par_real, model_data_set_par_complex
procedure, private :: model_data_set_par_real
procedure, private :: model_data_set_par_complex
<<Model data: sub interfaces>>=
module subroutine model_data_set_par_real (model, name, value)
class(model_data_t), intent(inout) :: model
type(string_t), intent(in) :: name
real(default), intent(in) :: value
end subroutine model_data_set_par_real
module subroutine model_data_set_par_complex (model, name, value)
class(model_data_t), intent(inout) :: model
type(string_t), intent(in) :: name
complex(default), intent(in) :: value
end subroutine model_data_set_par_complex
<<Model data: procedures>>=
module subroutine model_data_set_par_real (model, name, value)
class(model_data_t), intent(inout) :: model
type(string_t), intent(in) :: name
real(default), intent(in) :: value
class(modelpar_data_t), pointer :: par
par => model%get_par_data_ptr (name)
par = value
end subroutine model_data_set_par_real
module subroutine model_data_set_par_complex (model, name, value)
class(model_data_t), intent(inout) :: model
type(string_t), intent(in) :: name
complex(default), intent(in) :: value
class(modelpar_data_t), pointer :: par
par => model%get_par_data_ptr (name)
par = value
end subroutine model_data_set_par_complex
@ %def model_data_set_par_real model_data_set_par_complex
@ List all fields in the model.
<<Model data: model data: TBP>>=
procedure :: write_fields => model_data_write_fields
<<Model data: sub interfaces>>=
module subroutine model_data_write_fields (model, unit)
class(model_data_t), intent(in) :: model
integer, intent(in), optional :: unit
end subroutine model_data_write_fields
<<Model data: procedures>>=
module subroutine model_data_write_fields (model, unit)
class(model_data_t), intent(in) :: model
integer, intent(in), optional :: unit
integer :: i
do i = 1, size (model%field)
call model%field(i)%write (unit)
end do
end subroutine model_data_write_fields
@ %def model_data_write_fields
@ After initialization, return number of fields (particles):
<<Model data: model data: TBP>>=
procedure :: get_n_field => model_data_get_n_field
<<Model data: sub interfaces>>=
module function model_data_get_n_field (model) result (n)
class(model_data_t), intent(in) :: model
integer :: n
end function model_data_get_n_field
<<Model data: procedures>>=
module function model_data_get_n_field (model) result (n)
class(model_data_t), intent(in) :: model
integer :: n
n = size (model%field)
end function model_data_get_n_field
@ %def model_data_get_n_field
@ Return the PDG code of a field. The field is identified by name or
by index. If the field is not found, return zero.
<<Model data: model data: TBP>>=
generic :: get_pdg => &
model_data_get_field_pdg_index, &
model_data_get_field_pdg_name
procedure, private :: model_data_get_field_pdg_index
procedure, private :: model_data_get_field_pdg_name
<<Model data: sub interfaces>>=
module function model_data_get_field_pdg_index (model, i) result (pdg)
class(model_data_t), intent(in) :: model
integer, intent(in) :: i
integer :: pdg
end function model_data_get_field_pdg_index
module function model_data_get_field_pdg_name &
(model, name, check) result (pdg)
class(model_data_t), intent(in) :: model
type(string_t), intent(in) :: name
logical, intent(in), optional :: check
integer :: pdg
end function model_data_get_field_pdg_name
<<Model data: procedures>>=
module function model_data_get_field_pdg_index (model, i) result (pdg)
class(model_data_t), intent(in) :: model
integer, intent(in) :: i
integer :: pdg
pdg = model%field(i)%get_pdg ()
end function model_data_get_field_pdg_index
module function model_data_get_field_pdg_name &
(model, name, check) result (pdg)
class(model_data_t), intent(in) :: model
type(string_t), intent(in) :: name
logical, intent(in), optional :: check
integer :: pdg
integer :: i
do i = 1, size (model%field)
associate (field => model%field(i))
if (field%matches_name (name, .false.)) then
pdg = field%get_pdg ()
return
else if (field%matches_name (name, .true.)) then
pdg = - field%get_pdg ()
return
end if
end associate
end do
pdg = 0
call model%field_error (check, name)
end function model_data_get_field_pdg_name
@ %def model_data_get_field_pdg
@ Return an array of all PDG codes, including antiparticles. The antiparticle
are sorted after all particles.
<<Model data: model data: TBP>>=
procedure :: get_all_pdg => model_data_get_all_pdg
<<Model data: sub interfaces>>=
module subroutine model_data_get_all_pdg (model, pdg)
class(model_data_t), intent(in) :: model
integer, dimension(:), allocatable, intent(inout) :: pdg
end subroutine model_data_get_all_pdg
<<Model data: procedures>>=
module subroutine model_data_get_all_pdg (model, pdg)
class(model_data_t), intent(in) :: model
integer, dimension(:), allocatable, intent(inout) :: pdg
integer :: n0, n1, i, k
n0 = size (model%field)
n1 = n0 + count (model%field%has_antiparticle ())
allocate (pdg (n1))
pdg(1:n0) = model%field%get_pdg ()
k = n0
do i = 1, size (model%field)
associate (field => model%field(i))
if (field%has_antiparticle ()) then
k = k + 1
pdg(k) = - field%get_pdg ()
end if
end associate
end do
end subroutine model_data_get_all_pdg
@ %def model_data_get_all_pdg
@ Return pointer to the field array.
<<Model data: model data: TBP>>=
procedure :: get_field_array_ptr => model_data_get_field_array_ptr
<<Model data: sub interfaces>>=
module function model_data_get_field_array_ptr (model) result (ptr)
class(model_data_t), intent(in), target :: model
type(field_data_t), dimension(:), pointer :: ptr
end function model_data_get_field_array_ptr
<<Model data: procedures>>=
module function model_data_get_field_array_ptr (model) result (ptr)
class(model_data_t), intent(in), target :: model
type(field_data_t), dimension(:), pointer :: ptr
ptr => model%field
end function model_data_get_field_array_ptr
@ %def model_data_get_field_array_ptr
@ Return pointer to a field. The identifier should be the unique long
name, the PDG code, or the index.
We can issue an error message, if the [[check]] flag is set. We never return
an error if the PDG code is zero, this yields just a null pointer.
<<Model data: model data: TBP>>=
generic :: get_field_ptr => &
model_data_get_field_ptr_name, &
model_data_get_field_ptr_pdg
procedure, private :: model_data_get_field_ptr_name
procedure, private :: model_data_get_field_ptr_pdg
procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index
<<Model data: sub interfaces>>=
module function model_data_get_field_ptr_name &
(model, name, check) result (ptr)
class(model_data_t), intent(in), target :: model
type(string_t), intent(in) :: name
logical, intent(in), optional :: check
type(field_data_t), pointer :: ptr
end function model_data_get_field_ptr_name
module function model_data_get_field_ptr_pdg &
(model, pdg, check) result (ptr)
class(model_data_t), intent(in), target :: model
integer, intent(in) :: pdg
logical, intent(in), optional :: check
type(field_data_t), pointer :: ptr
end function model_data_get_field_ptr_pdg
module function model_data_get_field_ptr_index (model, i) result (ptr)
class(model_data_t), intent(in), target :: model
integer, intent(in) :: i
type(field_data_t), pointer :: ptr
end function model_data_get_field_ptr_index
<<Model data: procedures>>=
module function model_data_get_field_ptr_name &
(model, name, check) result (ptr)
class(model_data_t), intent(in), target :: model
type(string_t), intent(in) :: name
logical, intent(in), optional :: check
type(field_data_t), pointer :: ptr
integer :: i
do i = 1, size (model%field)
if (model%field(i)%matches_name (name, .false.)) then
ptr => model%field(i)
return
else if (model%field(i)%matches_name (name, .true.)) then
ptr => model%field(i)
return
end if
end do
ptr => null ()
call model%field_error (check, name)
end function model_data_get_field_ptr_name
module function model_data_get_field_ptr_pdg (model, pdg, check) result (ptr)
class(model_data_t), intent(in), target :: model
integer, intent(in) :: pdg
logical, intent(in), optional :: check
type(field_data_t), pointer :: ptr
integer :: i, pdg_abs
if (pdg == 0) then
ptr => null ()
return
end if
pdg_abs = abs (pdg)
do i = 1, size (model%field)
if (abs(model%field(i)%get_pdg ()) == pdg_abs) then
ptr => model%field(i)
return
end if
end do
ptr => null ()
call model%field_error (check, pdg=pdg)
end function model_data_get_field_ptr_pdg
module function model_data_get_field_ptr_index (model, i) result (ptr)
class(model_data_t), intent(in), target :: model
integer, intent(in) :: i
type(field_data_t), pointer :: ptr
ptr => model%field(i)
end function model_data_get_field_ptr_index
@ %def model_data_get_field_ptr
@ Do not assign a pointer, just check.
<<Model data: model data: TBP>>=
procedure :: test_field => model_data_test_field_pdg
<<Model data: sub interfaces>>=
module function model_data_test_field_pdg (model, pdg, check) result (exist)
class(model_data_t), intent(in), target :: model
integer, intent(in) :: pdg
logical, intent(in), optional :: check
logical :: exist
end function model_data_test_field_pdg
<<Model data: procedures>>=
module function model_data_test_field_pdg (model, pdg, check) result (exist)
class(model_data_t), intent(in), target :: model
integer, intent(in) :: pdg
logical, intent(in), optional :: check
logical :: exist
exist = associated (model%get_field_ptr (pdg, check))
end function model_data_test_field_pdg
@ %def model_data_test_field_pdg
@ Error message, if [[check]] is set.
<<Model data: model data: TBP>>=
procedure :: field_error => model_data_field_error
<<Model data: sub interfaces>>=
module subroutine model_data_field_error (model, check, name, pdg)
class(model_data_t), intent(in) :: model
logical, intent(in), optional :: check
type(string_t), intent(in), optional :: name
integer, intent(in), optional :: pdg
end subroutine model_data_field_error
<<Model data: procedures>>=
module subroutine model_data_field_error (model, check, name, pdg)
class(model_data_t), intent(in) :: model
logical, intent(in), optional :: check
type(string_t), intent(in), optional :: name
integer, intent(in), optional :: pdg
if (present (check)) then
if (check) then
if (present (name)) then
write (msg_buffer, "(A,1x,A,1x,A,1x,A)") &
"No particle with name", char (name), &
"is contained in model", char (model%name)
else if (present (pdg)) then
write (msg_buffer, "(A,1x,I0,1x,A,1x,A)") &
"No particle with PDG code", pdg, &
"is contained in model", char (model%name)
else
write (msg_buffer, "(A,1x,A,1x,A)") &
"Particle missing", &
"in model", char (model%name)
end if
call msg_fatal ()
end if
end if
end subroutine model_data_field_error
@ %def model_data_field_error
@ Assign mass and width value, which are associated via pointer.
Identify the particle via pdg.
<<Model data: model data: TBP>>=
procedure :: set_field_mass => model_data_set_field_mass_pdg
procedure :: set_field_width => model_data_set_field_width_pdg
<<Model data: sub interfaces>>=
module subroutine model_data_set_field_mass_pdg (model, pdg, value)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: pdg
real(default), intent(in) :: value
end subroutine model_data_set_field_mass_pdg
module subroutine model_data_set_field_width_pdg (model, pdg, value)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: pdg
real(default), intent(in) :: value
end subroutine model_data_set_field_width_pdg
<<Model data: procedures>>=
module subroutine model_data_set_field_mass_pdg (model, pdg, value)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: pdg
real(default), intent(in) :: value
type(field_data_t), pointer :: field
field => model%get_field_ptr (pdg, check = .true.)
call field%set_mass (value)
end subroutine model_data_set_field_mass_pdg
module subroutine model_data_set_field_width_pdg (model, pdg, value)
class(model_data_t), intent(inout) :: model
integer, intent(in) :: pdg
real(default), intent(in) :: value
type(field_data_t), pointer :: field
field => model%get_field_ptr (pdg, check = .true.)
call field%set_width (value)
end subroutine model_data_set_field_width_pdg
@ %def model_data_set_field_mass
@ %def model_data_set_field_width
@ Mark a particle as unstable and provide a list of names for its
decay processes. In contrast with the previous subroutine which is
for internal use, we address the particle by its PDG code. If the
index is negative, we address the antiparticle.
<<Model data: model data: TBP>>=
procedure :: set_unstable => model_data_set_unstable
procedure :: set_stable => model_data_set_stable
<<Model data: sub interfaces>>=
module subroutine model_data_set_unstable &
(model, pdg, decay, isotropic, diagonal, decay_helicity)
class(model_data_t), intent(inout), target :: model
integer, intent(in) :: pdg
type(string_t), dimension(:), intent(in) :: decay
logical, intent(in), optional :: isotropic, diagonal
integer, intent(in), optional :: decay_helicity
end subroutine model_data_set_unstable
module subroutine model_data_set_stable (model, pdg)
class(model_data_t), intent(inout), target :: model
integer, intent(in) :: pdg
end subroutine model_data_set_stable
<<Model data: procedures>>=
module subroutine model_data_set_unstable &
(model, pdg, decay, isotropic, diagonal, decay_helicity)
class(model_data_t), intent(inout), target :: model
integer, intent(in) :: pdg
type(string_t), dimension(:), intent(in) :: decay
logical, intent(in), optional :: isotropic, diagonal
integer, intent(in), optional :: decay_helicity
type(field_data_t), pointer :: field
field => model%get_field_ptr (pdg)
if (pdg > 0) then
call field%set ( &
p_is_stable = .false., p_decay = decay, &
p_decays_isotropically = isotropic, &
p_decays_diagonal = diagonal, &
p_decay_helicity = decay_helicity)
else
call field%set ( &
a_is_stable = .false., a_decay = decay, &
a_decays_isotropically = isotropic, &
a_decays_diagonal = diagonal, &
a_decay_helicity = decay_helicity)
end if
end subroutine model_data_set_unstable
module subroutine model_data_set_stable (model, pdg)
class(model_data_t), intent(inout), target :: model
integer, intent(in) :: pdg
type(field_data_t), pointer :: field
field => model%get_field_ptr (pdg)
if (pdg > 0) then
call field%set (p_is_stable = .true.)
else
call field%set (a_is_stable = .true.)
end if
end subroutine model_data_set_stable
@ %def model_data_set_unstable
@ %def model_data_set_stable
@ Mark a particle as polarized.
<<Model data: model data: TBP>>=
procedure :: set_polarized => model_data_set_polarized
procedure :: set_unpolarized => model_data_set_unpolarized
<<Model data: sub interfaces>>=
module subroutine model_data_set_polarized (model, pdg)
class(model_data_t), intent(inout), target :: model
integer, intent(in) :: pdg
end subroutine model_data_set_polarized
module subroutine model_data_set_unpolarized (model, pdg)
class(model_data_t), intent(inout), target :: model
integer, intent(in) :: pdg
end subroutine model_data_set_unpolarized
<<Model data: procedures>>=
module subroutine model_data_set_polarized (model, pdg)
class(model_data_t), intent(inout), target :: model
integer, intent(in) :: pdg
type(field_data_t), pointer :: field
field => model%get_field_ptr (pdg)
if (pdg > 0) then
call field%set (p_polarized = .true.)
else
call field%set (a_polarized = .true.)
end if
end subroutine model_data_set_polarized
module subroutine model_data_set_unpolarized (model, pdg)
class(model_data_t), intent(inout), target :: model
integer, intent(in) :: pdg
type(field_data_t), pointer :: field
field => model%get_field_ptr (pdg)
if (pdg > 0) then
call field%set (p_polarized = .false.)
else
call field%set (a_polarized = .false.)
end if
end subroutine model_data_set_unpolarized
@ %def model_data_set_polarized
@ %def model_data_set_unpolarized
@ Revert all polarized (unstable) particles to unpolarized (stable)
status, respectively.
<<Model data: model data: TBP>>=
procedure :: clear_unstable => model_clear_unstable
procedure :: clear_polarized => model_clear_polarized
<<Model data: sub interfaces>>=
module subroutine model_clear_unstable (model)
class(model_data_t), intent(inout), target :: model
end subroutine model_clear_unstable
module subroutine model_clear_polarized (model)
class(model_data_t), intent(inout), target :: model
end subroutine model_clear_polarized
<<Model data: procedures>>=
module subroutine model_clear_unstable (model)
class(model_data_t), intent(inout), target :: model
integer :: i
type(field_data_t), pointer :: field
do i = 1, model%get_n_field ()
field => model%get_field_ptr_by_index (i)
call field%set (p_is_stable = .true.)
if (field%has_antiparticle ()) then
call field%set (a_is_stable = .true.)
end if
end do
end subroutine model_clear_unstable
module subroutine model_clear_polarized (model)
class(model_data_t), intent(inout), target :: model
integer :: i
type(field_data_t), pointer :: field
do i = 1, model%get_n_field ()
field => model%get_field_ptr_by_index (i)
call field%set (p_polarized = .false.)
if (field%has_antiparticle ()) then
call field%set (a_polarized = .false.)
end if
end do
end subroutine model_clear_polarized
@ %def model_clear_unstable
@ %def model_clear_polarized
@ List all vertices, optionally also the hash table.
<<Model data: model data: TBP>>=
procedure :: write_vertices => model_data_write_vertices
<<Model data: sub interfaces>>=
module subroutine model_data_write_vertices (model, unit, verbose)
class(model_data_t), intent(in) :: model
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
end subroutine model_data_write_vertices
<<Model data: procedures>>=
module subroutine model_data_write_vertices (model, unit, verbose)
class(model_data_t), intent(in) :: model
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer :: i, u
u = given_output_unit (unit)
do i = 1, size (model%vtx)
call vertex_write (model%vtx(i), unit)
end do
if (present (verbose)) then
if (verbose) then
write (u, *)
call vertex_table_write (model%vt, unit)
end if
end if
end subroutine model_data_write_vertices
@ %def model_data_write_vertices
@ Vertex definition.
<<Model data: model data: TBP>>=
generic :: set_vertex => &
model_data_set_vertex_pdg, model_data_set_vertex_names
procedure, private :: model_data_set_vertex_pdg
procedure, private :: model_data_set_vertex_names
<<Model data: sub interfaces>>=
module subroutine model_data_set_vertex_pdg (model, i, pdg)
class(model_data_t), intent(inout), target :: model
integer, intent(in) :: i
integer, dimension(:), intent(in) :: pdg
end subroutine model_data_set_vertex_pdg
module subroutine model_data_set_vertex_names (model, i, name)
class(model_data_t), intent(inout), target :: model
integer, intent(in) :: i
type(string_t), dimension(:), intent(in) :: name
end subroutine model_data_set_vertex_names
<<Model data: procedures>>=
module subroutine model_data_set_vertex_pdg (model, i, pdg)
class(model_data_t), intent(inout), target :: model
integer, intent(in) :: i
integer, dimension(:), intent(in) :: pdg
call vertex_init (model%vtx(i), pdg, model)
end subroutine model_data_set_vertex_pdg
module subroutine model_data_set_vertex_names (model, i, name)
class(model_data_t), intent(inout), target :: model
integer, intent(in) :: i
type(string_t), dimension(:), intent(in) :: name
integer, dimension(size(name)) :: pdg
integer :: j
do j = 1, size (name)
pdg(j) = model%get_pdg (name(j))
end do
call model%set_vertex (i, pdg)
end subroutine model_data_set_vertex_names
@ %def model_data_set_vertex
@ Finalize vertex definition: set up the hash table.
<<Model data: model data: TBP>>=
procedure :: freeze_vertices => model_data_freeze_vertices
<<Model data: sub interfaces>>=
module subroutine model_data_freeze_vertices (model)
class(model_data_t), intent(inout) :: model
end subroutine model_data_freeze_vertices
<<Model data: procedures>>=
module subroutine model_data_freeze_vertices (model)
class(model_data_t), intent(inout) :: model
call model%vt%init (model%field, model%vtx)
end subroutine model_data_freeze_vertices
@ %def model_data_freeze_vertices
@ Number of vertices in model
<<Model data: model data: TBP>>=
procedure :: get_n_vtx => model_data_get_n_vtx
<<Model data: sub interfaces>>=
module function model_data_get_n_vtx (model) result (n)
class(model_data_t), intent(in) :: model
integer :: n
end function model_data_get_n_vtx
<<Model data: procedures>>=
module function model_data_get_n_vtx (model) result (n)
class(model_data_t), intent(in) :: model
integer :: n
n = size (model%vtx)
end function model_data_get_n_vtx
@ %def model_data_get_n_vtx
@ Lookup functions
<<Model data: model data: TBP>>=
procedure :: match_vertex => model_data_match_vertex
<<Model data: sub interfaces>>=
module subroutine model_data_match_vertex (model, pdg1, pdg2, pdg3)
class(model_data_t), intent(in) :: model
integer, intent(in) :: pdg1, pdg2
integer, dimension(:), allocatable, intent(out) :: pdg3
end subroutine model_data_match_vertex
<<Model data: procedures>>=
module subroutine model_data_match_vertex (model, pdg1, pdg2, pdg3)
class(model_data_t), intent(in) :: model
integer, intent(in) :: pdg1, pdg2
integer, dimension(:), allocatable, intent(out) :: pdg3
call model%vt%match (pdg1, pdg2, pdg3)
end subroutine model_data_match_vertex
@ %def model_data_match_vertex
<<Model data: model data: TBP>>=
procedure :: check_vertex => model_data_check_vertex
<<Model data: sub interfaces>>=
module function model_data_check_vertex &
(model, pdg1, pdg2, pdg3) result (flag)
logical :: flag
class(model_data_t), intent(in) :: model
integer, intent(in) :: pdg1, pdg2, pdg3
end function model_data_check_vertex
<<Model data: procedures>>=
module function model_data_check_vertex &
(model, pdg1, pdg2, pdg3) result (flag)
logical :: flag
class(model_data_t), intent(in) :: model
integer, intent(in) :: pdg1, pdg2, pdg3
flag = model%vt%check (pdg1, pdg2, pdg3)
end function model_data_check_vertex
@ %def model_data_check_vertex
@
\subsection{Toy Models}
This is a stripped-down version of the (already trivial) model 'Test'.
<<Model data: model data: TBP>>=
procedure :: init_test => model_data_init_test
<<Model data: sub interfaces>>=
module subroutine model_data_init_test (model)
class(model_data_t), intent(out) :: model
end subroutine model_data_init_test
<<Model data: procedures>>=
module subroutine model_data_init_test (model)
class(model_data_t), intent(out) :: model
type(field_data_t), pointer :: field
integer, parameter :: n_real = 4
integer, parameter :: n_field = 2
integer, parameter :: n_vertex = 2
integer :: i
call model%init (var_str ("Test"), &
n_real, 0, n_field, n_vertex)
i = 0
i = i + 1
call model%init_par (i, var_str ("gy"), 1._default)
i = i + 1
call model%init_par (i, var_str ("ms"), 125._default)
i = i + 1
call model%init_par (i, var_str ("ff"), 1.5_default)
i = i + 1
call model%init_par (i, var_str ("mf"), 1.5_default * 125._default)
i = 0
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("SCALAR"), 25)
call field%set (spin_type=1)
call field%set (mass_data=model%get_par_real_ptr (2))
call field%set (name = [var_str ("s")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("FERMION"), 6)
call field%set (spin_type=2)
call field%set (mass_data=model%get_par_real_ptr (4))
call field%set (name = [var_str ("f")], anti = [var_str ("fbar")])
call model%freeze_fields ()
i = 0
i = i + 1
call model%set_vertex (i, [var_str ("fbar"), var_str ("f"), var_str ("s")])
i = i + 1
call model%set_vertex (i, [var_str ("s"), var_str ("s"), var_str ("s")])
call model%freeze_vertices ()
end subroutine model_data_init_test
@ %def model_data_init_test
@
This procedure prepares a subset of QED for testing purposes.
<<Model data: model data: TBP>>=
procedure :: init_qed_test => model_data_init_qed_test
<<Model data: sub interfaces>>=
module subroutine model_data_init_qed_test (model)
class(model_data_t), intent(out) :: model
end subroutine model_data_init_qed_test
<<Model data: procedures>>=
module subroutine model_data_init_qed_test (model)
class(model_data_t), intent(out) :: model
type(field_data_t), pointer :: field
integer, parameter :: n_real = 1
integer, parameter :: n_field = 2
integer :: i
call model%init (var_str ("QED_test"), &
n_real, 0, n_field, 0)
i = 0
i = i + 1
call model%init_par (i, var_str ("me"), 0.000510997_default)
i = 0
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("E_LEPTON"), 11)
call field%set (spin_type=2, charge_type=-4)
call field%set (mass_data=model%get_par_real_ptr (1))
call field%set (name = [var_str ("e-")], anti = [var_str ("e+")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("PHOTON"), 22)
call field%set (spin_type=3)
call field%set (name = [var_str ("A")])
call model%freeze_fields ()
call model%freeze_vertices ()
end subroutine model_data_init_qed_test
@ %def model_data_init_qed_test
@
This procedure prepares a subset of the Standard Model for testing purposes.
We can thus avoid dependencies on model I/O, which is not defined here.
<<Model data: model data: TBP>>=
procedure :: init_sm_test => model_data_init_sm_test
<<Model data: sub interfaces>>=
module subroutine model_data_init_sm_test (model)
class(model_data_t), intent(out) :: model
end subroutine model_data_init_sm_test
<<Model data: procedures>>=
module subroutine model_data_init_sm_test (model)
class(model_data_t), intent(out) :: model
type(field_data_t), pointer :: field
integer, parameter :: n_real = 11
integer, parameter :: n_field = 19
integer, parameter :: n_vtx = 9
integer :: i
call model%init (var_str ("SM_test"), &
n_real, 0, n_field, n_vtx)
i = 0
i = i + 1
call model%init_par (i, var_str ("mZ"), 91.1882_default)
i = i + 1
call model%init_par (i, var_str ("mW"), 80.419_default)
i = i + 1
call model%init_par (i, var_str ("me"), 0.000510997_default)
i = i + 1
call model%init_par (i, var_str ("mmu"), 0.105658389_default)
i = i + 1
call model%init_par (i, var_str ("mb"), 4.2_default)
i = i + 1
call model%init_par (i, var_str ("mtop"), 173.1_default)
i = i + 1
call model%init_par (i, var_str ("wZ"), 2.443_default)
i = i + 1
call model%init_par (i, var_str ("wW"), 2.049_default)
i = i + 1
call model%init_par (i, var_str ("ee"), 0.3079561542961_default)
i = i + 1
call model%init_par (i, var_str ("cw"), 8.819013863636E-01_default)
i = i + 1
call model%init_par (i, var_str ("sw"), 4.714339240339E-01_default)
i = 0
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("D_QUARK"), 1)
call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
call field%set (name = [var_str ("d")], anti = [var_str ("dbar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("U_QUARK"), 2)
call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
call field%set (name = [var_str ("u")], anti = [var_str ("ubar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("S_QUARK"), 3)
call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
call field%set (name = [var_str ("s")], anti = [var_str ("sbar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("C_QUARK"), 4)
call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
call field%set (name = [var_str ("c")], anti = [var_str ("cbar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("B_QUARK"), 5)
call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
call field%set (mass_data=model%get_par_real_ptr (5))
call field%set (name = [var_str ("b")], anti = [var_str ("bbar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("T_QUARK"), 6)
call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
call field%set (mass_data=model%get_par_real_ptr (6))
call field%set (name = [var_str ("t")], anti = [var_str ("tbar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("E_LEPTON"), 11)
call field%set (spin_type=2)
call field%set (mass_data=model%get_par_real_ptr (3))
call field%set (name = [var_str ("e-")], anti = [var_str ("e+")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("E_NEUTRINO"), 12)
call field%set (spin_type=2, is_left_handed=.true.)
call field%set (name = [var_str ("nue")], anti = [var_str ("nuebar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("MU_LEPTON"), 13)
call field%set (spin_type=2)
call field%set (mass_data=model%get_par_real_ptr (4))
call field%set (name = [var_str ("mu-")], anti = [var_str ("mu+")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("MU_NEUTRINO"), 14)
call field%set (spin_type=2, is_left_handed=.true.)
call field%set (name = [var_str ("numu")], anti = [var_str ("numubar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("GLUON"), 21)
call field%set (spin_type=3, color_type=8)
call field%set (name = [var_str ("gl")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("PHOTON"), 22)
call field%set (spin_type=3)
call field%set (name = [var_str ("A")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("Z_BOSON"), 23)
call field%set (spin_type=3)
call field%set (mass_data=model%get_par_real_ptr (1))
call field%set (width_data=model%get_par_real_ptr (7))
call field%set (name = [var_str ("Z")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("W_BOSON"), 24)
call field%set (spin_type=3)
call field%set (mass_data=model%get_par_real_ptr (2))
call field%set (width_data=model%get_par_real_ptr (8))
call field%set (name = [var_str ("W+")], anti = [var_str ("W-")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("HIGGS"), 25)
call field%set (spin_type=1)
! call field%set (mass_data=model%get_par_real_ptr (2))
! call field%set (width_data=model%get_par_real_ptr (8))
call field%set (name = [var_str ("H")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("PROTON"), 2212)
call field%set (spin_type=2)
call field%set (name = [var_str ("p")], anti = [var_str ("pbar")])
! call field%set (mass_data=model%get_par_real_ptr (12))
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("HADRON_REMNANT_SINGLET"), 91)
call field%set (color_type=1)
call field%set (name = [var_str ("hr1")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("HADRON_REMNANT_TRIPLET"), 92)
call field%set (color_type=3)
call field%set (name = [var_str ("hr3")], anti = [var_str ("hr3bar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("HADRON_REMNANT_OCTET"), 93)
call field%set (color_type=8)
call field%set (name = [var_str ("hr8")])
call model%freeze_fields ()
i = 0
i = i + 1
call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("A")])
i = i + 1
call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("A")])
i = i + 1
call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), var_str ("gl")])
i = i + 1
call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("gl")])
i = i + 1
call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("gl")])
i = i + 1
call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("ubar"), var_str ("d"), var_str ("W+")])
i = i + 1
call model%set_vertex (i, [var_str ("dbar"), var_str ("u"), var_str ("W-")])
call model%freeze_vertices ()
end subroutine model_data_init_sm_test
@ %def model_data_init_sm_test
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Model Testbed}
The standard way of defining a model uses concrete variables and expressions to
interpret the model file. Some of this is not available at the point of use. This
is no problem for the \whizard\ program as a whole, but unit tests are
kept local to their respective module and don't access all definitions.
Instead, we introduce a separate module that provides hooks, one for
initializing a model and one for finalizing a model. The main program can
assign real routines to the hooks (procedure pointers of abstract type) before
unit tests are called. The unit tests can call the abstract routines without
knowing about their implementation.
<<[[model_testbed.f90]]>>=
<<File header>>
module model_testbed
<<Use strings>>
use model_data
use var_base
<<Standard module head>>
<<Model testbed: public>>
<<Model testbed: variables>>
<<Model testbed: interfaces>>
end module model_testbed
@ %def model_testbed
@
\subsection{Abstract Model Handlers}
Both routines take a polymorphic model (data) target, which
is not allocated/deallocated inside the subroutine. The model constructor
[[prepare_model]] requires the model name as input. It can, optionally,
return a link to the variable list of the model.
<<Model testbed: public>>=
public :: prepare_model
public :: cleanup_model
<<Model testbed: variables>>=
procedure (prepare_model_proc), pointer :: prepare_model => null ()
procedure (cleanup_model_proc), pointer :: cleanup_model => null ()
<<Model testbed: interfaces>>=
abstract interface
subroutine prepare_model_proc (model, name, vars)
import
class(model_data_t), intent(inout), pointer :: model
type(string_t), intent(in) :: name
class(vars_t), pointer, intent(out), optional :: vars
end subroutine prepare_model_proc
end interface
abstract interface
subroutine cleanup_model_proc (model)
import
class(model_data_t), intent(inout), target :: model
end subroutine cleanup_model_proc
end interface
@ %def prepare_model
@ %def cleanup_model
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Helicities}
This module defines types and tools for dealing with helicity
information.
<<[[helicities.f90]]>>=
<<File header>>
module helicities
<<Standard module head>>
<<Helicities: public>>
<<Helicities: types>>
<<Helicities: interfaces>>
interface
<<Helicities: sub interfaces>>
end interface
end module helicities
@ %def helicities
@
<<[[helicities_sub.f90]]>>=
<<File header>>
submodule (helicities) helicities_s
use io_units
implicit none
contains
<<Helicities: procedures>>
end submodule helicities_s
@ %def helicities_s
@
\subsection{Helicity types}
Helicities may be defined or undefined, corresponding to a polarized
or unpolarized state. Each helicity is actually a pair of helicities,
corresponding to an entry in the spin density matrix. Obviously,
diagonal entries are distinguished.
<<Helicities: public>>=
public :: helicity_t
<<Helicities: types>>=
type :: helicity_t
private
logical :: defined = .false.
integer :: h1, h2
contains
<<Helicities: helicity: TBP>>
end type helicity_t
@ %def helicity_t
@ Constructor functions, for convenience:
<<Helicities: public>>=
public :: helicity
<<Helicities: interfaces>>=
interface helicity
module procedure helicity0, helicity1, helicity2
end interface helicity
<<Helicities: sub interfaces>>=
pure module function helicity0 () result (hel)
type(helicity_t) :: hel
end function helicity0
elemental module function helicity1 (h) result (hel)
type(helicity_t) :: hel
integer, intent(in) :: h
end function helicity1
elemental module function helicity2 (h2, h1) result (hel)
type(helicity_t) :: hel
integer, intent(in) :: h1, h2
end function helicity2
<<Helicities: procedures>>=
pure module function helicity0 () result (hel)
type(helicity_t) :: hel
end function helicity0
elemental module function helicity1 (h) result (hel)
type(helicity_t) :: hel
integer, intent(in) :: h
call hel%init (h)
end function helicity1
elemental module function helicity2 (h2, h1) result (hel)
type(helicity_t) :: hel
integer, intent(in) :: h1, h2
call hel%init (h2, h1)
end function helicity2
@ %def helicity
@ Initializers.
Note: conceptually, the argument to initializers should be INTENT(OUT).
However, Interp.\ F08/0033 prohibited this. The reason is that, in principle,
the call could result in the execution of an impure finalizer for a type
extension of [[hel]] (ugh).
<<Helicities: helicity: TBP>>=
generic :: init => helicity_init_empty, helicity_init_same, helicity_init_different
procedure, private :: helicity_init_empty
procedure, private :: helicity_init_same
procedure, private :: helicity_init_different
<<Helicities: sub interfaces>>=
elemental module subroutine helicity_init_empty (hel)
class(helicity_t), intent(inout) :: hel
end subroutine helicity_init_empty
elemental module subroutine helicity_init_same (hel, h)
class(helicity_t), intent(inout) :: hel
integer, intent(in) :: h
end subroutine helicity_init_same
elemental module subroutine helicity_init_different (hel, h2, h1)
class(helicity_t), intent(inout) :: hel
integer, intent(in) :: h1, h2
end subroutine helicity_init_different
<<Helicities: procedures>>=
elemental module subroutine helicity_init_empty (hel)
class(helicity_t), intent(inout) :: hel
hel%defined = .false.
end subroutine helicity_init_empty
elemental module subroutine helicity_init_same (hel, h)
class(helicity_t), intent(inout) :: hel
integer, intent(in) :: h
hel%defined = .true.
hel%h1 = h
hel%h2 = h
end subroutine helicity_init_same
elemental module subroutine helicity_init_different (hel, h2, h1)
class(helicity_t), intent(inout) :: hel
integer, intent(in) :: h1, h2
hel%defined = .true.
hel%h2 = h2
hel%h1 = h1
end subroutine helicity_init_different
@ %def helicity_init
@ Undefine:
<<Helicities: helicity: TBP>>=
procedure :: undefine => helicity_undefine
<<Helicities: sub interfaces>>=
elemental module subroutine helicity_undefine (hel)
class(helicity_t), intent(inout) :: hel
end subroutine helicity_undefine
<<Helicities: procedures>>=
elemental module subroutine helicity_undefine (hel)
class(helicity_t), intent(inout) :: hel
hel%defined = .false.
end subroutine helicity_undefine
@ %def helicity_undefine
@ Diagonalize by removing the second entry (use with care!)
<<Helicities: helicity: TBP>>=
procedure :: diagonalize => helicity_diagonalize
<<Helicities: sub interfaces>>=
elemental module subroutine helicity_diagonalize (hel)
class(helicity_t), intent(inout) :: hel
end subroutine helicity_diagonalize
<<Helicities: procedures>>=
elemental module subroutine helicity_diagonalize (hel)
class(helicity_t), intent(inout) :: hel
hel%h2 = hel%h1
end subroutine helicity_diagonalize
@ %def helicity_diagonalize
@ Flip helicity indices by sign.
<<Helicities: helicity: TBP>>=
procedure :: flip => helicity_flip
<<Helicities: sub interfaces>>=
elemental module subroutine helicity_flip (hel)
class(helicity_t), intent(inout) :: hel
end subroutine helicity_flip
<<Helicities: procedures>>=
elemental module subroutine helicity_flip (hel)
class(helicity_t), intent(inout) :: hel
hel%h1 = - hel%h1
hel%h2 = - hel%h2
end subroutine helicity_flip
@ %def helicity_flip
@
<<Helicities: helicity: TBP>>=
procedure :: get_indices => helicity_get_indices
<<Helicities: sub interfaces>>=
module subroutine helicity_get_indices (hel, h1, h2)
class(helicity_t), intent(in) :: hel
integer, intent(out) :: h1, h2
end subroutine helicity_get_indices
<<Helicities: procedures>>=
module subroutine helicity_get_indices (hel, h1, h2)
class(helicity_t), intent(in) :: hel
integer, intent(out) :: h1, h2
h1 = hel%h1; h2 = hel%h2
end subroutine helicity_get_indices
@ %def helicity_get_indices
@ Output (no linebreak). No output if undefined.
<<Helicities: helicity: TBP>>=
procedure :: write => helicity_write
<<Helicities: sub interfaces>>=
module subroutine helicity_write (hel, unit)
class(helicity_t), intent(in) :: hel
integer, intent(in), optional :: unit
end subroutine helicity_write
<<Helicities: procedures>>=
module subroutine helicity_write (hel, unit)
class(helicity_t), intent(in) :: hel
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
if (hel%defined) then
write (u, "(A)", advance="no") "h("
write (u, "(I0)", advance="no") hel%h1
if (hel%h1 /= hel%h2) then
write (u, "(A)", advance="no") "|"
write (u, "(I0)", advance="no") hel%h2
end if
write (u, "(A)", advance="no") ")"
end if
end subroutine helicity_write
@ %def helicity_write
@ Binary I/O. Write contents only if defined.
<<Helicities: helicity: TBP>>=
procedure :: write_raw => helicity_write_raw
procedure :: read_raw => helicity_read_raw
<<Helicities: sub interfaces>>=
module subroutine helicity_write_raw (hel, u)
class(helicity_t), intent(in) :: hel
integer, intent(in) :: u
end subroutine helicity_write_raw
module subroutine helicity_read_raw (hel, u, iostat)
class(helicity_t), intent(out) :: hel
integer, intent(in) :: u
integer, intent(out), optional :: iostat
end subroutine helicity_read_raw
<<Helicities: procedures>>=
module subroutine helicity_write_raw (hel, u)
class(helicity_t), intent(in) :: hel
integer, intent(in) :: u
write (u) hel%defined
if (hel%defined) then
write (u) hel%h1, hel%h2
end if
end subroutine helicity_write_raw
module subroutine helicity_read_raw (hel, u, iostat)
class(helicity_t), intent(out) :: hel
integer, intent(in) :: u
integer, intent(out), optional :: iostat
read (u, iostat=iostat) hel%defined
if (hel%defined) then
read (u, iostat=iostat) hel%h1, hel%h2
end if
end subroutine helicity_read_raw
@ %def helicity_write_raw helicity_read_raw
@
\subsection{Predicates}
Check if the helicity is defined:
<<Helicities: helicity: TBP>>=
procedure :: is_defined => helicity_is_defined
<<Helicities: sub interfaces>>=
elemental module function helicity_is_defined (hel) result (defined)
logical :: defined
class(helicity_t), intent(in) :: hel
end function helicity_is_defined
<<Helicities: procedures>>=
elemental module function helicity_is_defined (hel) result (defined)
logical :: defined
class(helicity_t), intent(in) :: hel
defined = hel%defined
end function helicity_is_defined
@ %def helicity_is_defined
@ Return true if the two helicities are equal or the particle is unpolarized:
<<Helicities: helicity: TBP>>=
procedure :: is_diagonal => helicity_is_diagonal
<<Helicities: sub interfaces>>=
elemental module function helicity_is_diagonal (hel) result (diagonal)
logical :: diagonal
class(helicity_t), intent(in) :: hel
end function helicity_is_diagonal
<<Helicities: procedures>>=
elemental module function helicity_is_diagonal (hel) result (diagonal)
logical :: diagonal
class(helicity_t), intent(in) :: hel
if (hel%defined) then
diagonal = hel%h1 == hel%h2
else
diagonal = .true.
end if
end function helicity_is_diagonal
@ %def helicity_is_diagonal
@
\subsection{Accessing contents}
This returns a two-element array and thus cannot be elemental. The
result is unpredictable if the helicity is undefined.
<<Helicities: helicity: TBP>>=
procedure :: to_pair => helicity_to_pair
<<Helicities: sub interfaces>>=
pure module function helicity_to_pair (hel) result (h)
integer, dimension(2) :: h
class(helicity_t), intent(in) :: hel
end function helicity_to_pair
<<Helicities: procedures>>=
pure module function helicity_to_pair (hel) result (h)
integer, dimension(2) :: h
class(helicity_t), intent(in) :: hel
h(1) = hel%h2
h(2) = hel%h1
end function helicity_to_pair
@ %def helicity_to_pair
@
\subsection{Comparisons}
When comparing helicities, if either one is undefined, they are
considered to match. In other words, an unpolarized particle matches
any polarization. In the [[dmatch]] variant, it matches only diagonal
helicity.
<<Helicities: helicity: TBP>>=
generic :: operator(.match.) => helicity_match
generic :: operator(.dmatch.) => helicity_match_diagonal
generic :: operator(==) => helicity_eq
generic :: operator(/=) => helicity_neq
procedure, private :: helicity_match
procedure, private :: helicity_match_diagonal
procedure, private :: helicity_eq
procedure, private :: helicity_neq
@ %def .match. .dmatch. == /=
<<Helicities: sub interfaces>>=
elemental module function helicity_match (hel1, hel2) result (eq)
logical :: eq
class(helicity_t), intent(in) :: hel1, hel2
end function helicity_match
elemental module function helicity_match_diagonal (hel1, hel2) result (eq)
logical :: eq
class(helicity_t), intent(in) :: hel1, hel2
end function helicity_match_diagonal
<<Helicities: procedures>>=
elemental module function helicity_match (hel1, hel2) result (eq)
logical :: eq
class(helicity_t), intent(in) :: hel1, hel2
if (hel1%defined .and. hel2%defined) then
eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2)
else
eq = .true.
end if
end function helicity_match
elemental module function helicity_match_diagonal (hel1, hel2) result (eq)
logical :: eq
class(helicity_t), intent(in) :: hel1, hel2
if (hel1%defined .and. hel2%defined) then
eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2)
else if (hel1%defined) then
eq = hel1%h1 == hel1%h2
else if (hel2%defined) then
eq = hel2%h1 == hel2%h2
else
eq = .true.
end if
end function helicity_match_diagonal
@ %def helicity_match helicity_match_diagonal
<<Helicities: sub interfaces>>=
elemental module function helicity_eq (hel1, hel2) result (eq)
logical :: eq
class(helicity_t), intent(in) :: hel1, hel2
end function helicity_eq
<<Helicities: procedures>>=
elemental module function helicity_eq (hel1, hel2) result (eq)
logical :: eq
class(helicity_t), intent(in) :: hel1, hel2
if (hel1%defined .and. hel2%defined) then
eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2)
else if (.not. hel1%defined .and. .not. hel2%defined) then
eq = .true.
else
eq = .false.
end if
end function helicity_eq
@ %def helicity_eq
<<Helicities: sub interfaces>>=
elemental module function helicity_neq (hel1, hel2) result (neq)
logical :: neq
class(helicity_t), intent(in) :: hel1, hel2
end function helicity_neq
<<Helicities: procedures>>=
elemental module function helicity_neq (hel1, hel2) result (neq)
logical :: neq
class(helicity_t), intent(in) :: hel1, hel2
if (hel1%defined .and. hel2%defined) then
neq = (hel1%h1 /= hel2%h1) .or. (hel1%h2 /= hel2%h2)
else if (.not. hel1%defined .and. .not. hel2%defined) then
neq = .false.
else
neq = .true.
end if
end function helicity_neq
@ %def helicity_neq
@
\subsection{Tools}
Merge two helicity objects by taking the first entry from the first and
the second entry from the second argument. Makes sense only if the
input helicities were defined and diagonal. The handling of ghost
flags is not well-defined; one should verify beforehand that they
match.
<<Helicities: helicity: TBP>>=
generic :: operator(.merge.) => merge_helicities
procedure, private :: merge_helicities
@ %def .merge.
<<Helicities: sub interfaces>>=
elemental module function merge_helicities (hel1, hel2) result (hel)
type(helicity_t) :: hel
class(helicity_t), intent(in) :: hel1, hel2
end function merge_helicities
<<Helicities: procedures>>=
elemental module function merge_helicities (hel1, hel2) result (hel)
type(helicity_t) :: hel
class(helicity_t), intent(in) :: hel1, hel2
if (hel1%defined .and. hel2%defined) then
call hel%init (hel2%h1, hel1%h1)
else if (hel1%defined) then
call hel%init (hel1%h2, hel1%h1)
else if (hel2%defined) then
call hel%init (hel2%h2, hel2%h1)
end if
end function merge_helicities
@ %def merge_helicities
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Colors}
This module defines a type and tools for dealing with color information.
Each particle can have zero or more (in practice, usually not more
than two) color indices. Color indices are positive; flow direction
can be determined from the particle nature.
While parton shower matrix elements are diagonal in color, some
special applications (e.g., subtractions for NLO matrix elements)
require non-diagonal color matrices.
<<[[colors.f90]]>>=
<<File header>>
module colors
<<Use kinds>>
<<Use strings>>
<<Standard module head>>
<<Colors: public>>
<<Colors: types>>
<<Colors: interfaces>>
interface
<<Colors: sub interfaces>>
end interface
end module colors
@ %def colors
@
<<[[colors_sub.f90]]>>=
<<File header>>
submodule (colors) colors_s
use io_units
use diagnostics
implicit none
contains
<<Colors: procedures>>
end submodule colors_s
@ %def colors_s
@
\subsection{The color type}
A particle may have an arbitrary number of color indices (in practice,
from zero to two, but more are possible). This object acts as a
container. (The current implementation has a fixed array of length two.)
The fact that color comes as an array prohibits elemental procedures
in some places. (May add interfaces and multi versions where
necessary.)
The color may be undefined.
NOTE: Due to a compiler bug in nagfor 5.2, we do not use allocatable
but fixed-size arrays with dimension 2. Only nonzero entries count.
This may be more efficient anyway, but gives up some flexibility.
However, the squaring algorithm currently works only for singlets,
(anti)triplets and octets anyway, so two components are enough.
This type has to be generalized (abstract type and specific
implementations) when trying to pursue generalized color flows or
Monte Carlo over continuous color.
<<Colors: public>>=
public :: color_t
<<Colors: types>>=
type :: color_t
private
logical :: defined = .false.
integer, dimension(2) :: c1 = 0, c2 = 0
logical :: ghost = .false.
contains
<<Colors: color: TBP>>
end type color_t
@ %def color_t
<<Colors: types>>=
type :: entry_t
integer, dimension(:), allocatable :: map
type(color_t), dimension(:), allocatable :: col
type(entry_t), pointer :: next => null ()
logical :: nlo_event = .false.
end type entry_t
type :: list_t
integer :: n = 0
type(entry_t), pointer :: first => null ()
type(entry_t), pointer :: last => null ()
end type list_t
@ %def entry_t list_t
@ Initializers:
<<Colors: color: TBP>>=
generic :: init => &
color_init_trivial, color_init_trivial_ghost, &
color_init_array, color_init_array_ghost, &
color_init_arrays, color_init_arrays_ghost
procedure, private :: color_init_trivial
procedure, private :: color_init_trivial_ghost
procedure, private :: color_init_array
procedure, private :: color_init_array_ghost
procedure, private :: color_init_arrays
procedure, private :: color_init_arrays_ghost
@ Undefined color: array remains unallocated
<<Colors: sub interfaces>>=
pure module subroutine color_init_trivial (col)
class(color_t), intent(inout) :: col
end subroutine color_init_trivial
pure module subroutine color_init_trivial_ghost (col, ghost)
class(color_t), intent(inout) :: col
logical, intent(in) :: ghost
end subroutine color_init_trivial_ghost
<<Colors: procedures>>=
pure module subroutine color_init_trivial (col)
class(color_t), intent(inout) :: col
col%defined = .true.
col%c1 = 0
col%c2 = 0
col%ghost = .false.
end subroutine color_init_trivial
pure module subroutine color_init_trivial_ghost (col, ghost)
class(color_t), intent(inout) :: col
logical, intent(in) :: ghost
col%defined = .true.
col%c1 = 0
col%c2 = 0
col%ghost = ghost
end subroutine color_init_trivial_ghost
@ This defines color from an arbitrary length color array, suitable
for any representation. We may have two color arrays (non-diagonal
matrix elements). This cannot be elemental. The third version
assigns an array of colors, using a two-dimensional array as input.
<<Colors: sub interfaces>>=
pure module subroutine color_init_array (col, c1)
class(color_t), intent(inout) :: col
integer, dimension(:), intent(in) :: c1
end subroutine color_init_array
pure module subroutine color_init_array_ghost (col, c1, ghost)
class(color_t), intent(inout) :: col
integer, dimension(:), intent(in) :: c1
logical, intent(in) :: ghost
end subroutine color_init_array_ghost
pure module subroutine color_init_arrays (col, c1, c2)
class(color_t), intent(inout) :: col
integer, dimension(:), intent(in) :: c1, c2
end subroutine color_init_arrays
pure module subroutine color_init_arrays_ghost (col, c1, c2, ghost)
class(color_t), intent(inout) :: col
integer, dimension(:), intent(in) :: c1, c2
logical, intent(in) :: ghost
end subroutine color_init_arrays_ghost
<<Colors: procedures>>=
pure module subroutine color_init_array (col, c1)
class(color_t), intent(inout) :: col
integer, dimension(:), intent(in) :: c1
col%defined = .true.
col%c1 = pack (c1, c1 /= 0, [0,0])
col%c2 = col%c1
col%ghost = .false.
end subroutine color_init_array
pure module subroutine color_init_array_ghost (col, c1, ghost)
class(color_t), intent(inout) :: col
integer, dimension(:), intent(in) :: c1
logical, intent(in) :: ghost
call color_init_array (col, c1)
col%ghost = ghost
end subroutine color_init_array_ghost
pure module subroutine color_init_arrays (col, c1, c2)
class(color_t), intent(inout) :: col
integer, dimension(:), intent(in) :: c1, c2
col%defined = .true.
if (size (c1) == size (c2)) then
col%c1 = pack (c1, c1 /= 0, [0,0])
col%c2 = pack (c2, c2 /= 0, [0,0])
else if (size (c1) /= 0) then
col%c1 = pack (c1, c1 /= 0, [0,0])
col%c2 = col%c1
else if (size (c2) /= 0) then
col%c1 = pack (c2, c2 /= 0, [0,0])
col%c2 = col%c1
end if
col%ghost = .false.
end subroutine color_init_arrays
pure module subroutine color_init_arrays_ghost (col, c1, c2, ghost)
class(color_t), intent(inout) :: col
integer, dimension(:), intent(in) :: c1, c2
logical, intent(in) :: ghost
call color_init_arrays (col, c1, c2)
col%ghost = ghost
end subroutine color_init_arrays_ghost
@ %def color_init
@ This version is restricted to singlets, triplets, antitriplets, and
octets: The input contains the color and anticolor index, each of the
may be zero.
<<Colors: color: TBP>>=
procedure :: init_col_acl => color_init_col_acl
<<Colors: sub interfaces>>=
elemental module subroutine color_init_col_acl (col, col_in, acl_in)
class(color_t), intent(inout) :: col
integer, intent(in) :: col_in, acl_in
end subroutine color_init_col_acl
<<Colors: procedures>>=
elemental module subroutine color_init_col_acl (col, col_in, acl_in)
class(color_t), intent(inout) :: col
integer, intent(in) :: col_in, acl_in
integer, dimension(0) :: null_array
select case (col_in)
case (0)
select case (acl_in)
case (0)
call color_init_array (col, null_array)
case default
call color_init_array (col, [-acl_in])
end select
case default
select case (acl_in)
case (0)
call color_init_array (col, [col_in])
case default
call color_init_array (col, [col_in, -acl_in])
end select
end select
end subroutine color_init_col_acl
@ %def color_init_col_acl
@ This version is used for the external interface. We convert a
fixed-size array of colors (for each particle) to the internal form by
packing only the nonzero entries.
Some of these procedures produce an arry, so they can't be all
type-bound. We implement them as ordinary procedures.
<<Colors: public>>=
public :: color_init_from_array
<<Colors: interfaces>>=
interface color_init_from_array
module procedure color_init_from_array1
module procedure color_init_from_array1g
module procedure color_init_from_array2
module procedure color_init_from_array2g
end interface color_init_from_array
@ %def color_init_from_array
<<Colors: sub interfaces>>=
pure module subroutine color_init_from_array1 (col, c1)
type(color_t), intent(inout) :: col
integer, dimension(:), intent(in) :: c1
end subroutine color_init_from_array1
pure module subroutine color_init_from_array1g (col, c1, ghost)
type(color_t), intent(inout) :: col
integer, dimension(:), intent(in) :: c1
logical, intent(in) :: ghost
end subroutine color_init_from_array1g
pure module subroutine color_init_from_array2 (col, c1)
integer, dimension(:,:), intent(in) :: c1
type(color_t), dimension(:), intent(inout) :: col
end subroutine color_init_from_array2
pure module subroutine color_init_from_array2g (col, c1, ghost)
integer, dimension(:,:), intent(in) :: c1
type(color_t), dimension(:), intent(out) :: col
logical, intent(in), dimension(:) :: ghost
end subroutine color_init_from_array2g
<<Colors: procedures>>=
pure module subroutine color_init_from_array1 (col, c1)
type(color_t), intent(inout) :: col
integer, dimension(:), intent(in) :: c1
logical, dimension(size(c1)) :: mask
mask = c1 /= 0
col%defined = .true.
col%c1 = pack (c1, mask, col%c1)
col%c2 = col%c1
col%ghost = .false.
end subroutine color_init_from_array1
pure module subroutine color_init_from_array1g (col, c1, ghost)
type(color_t), intent(inout) :: col
integer, dimension(:), intent(in) :: c1
logical, intent(in) :: ghost
call color_init_from_array1 (col, c1)
col%ghost = ghost
end subroutine color_init_from_array1g
pure module subroutine color_init_from_array2 (col, c1)
integer, dimension(:,:), intent(in) :: c1
type(color_t), dimension(:), intent(inout) :: col
integer :: i
do i = 1, size (c1,2)
call color_init_from_array1 (col(i), c1(:,i))
end do
end subroutine color_init_from_array2
pure module subroutine color_init_from_array2g (col, c1, ghost)
integer, dimension(:,:), intent(in) :: c1
type(color_t), dimension(:), intent(out) :: col
logical, intent(in), dimension(:) :: ghost
call color_init_from_array2 (col, c1)
col%ghost = ghost
end subroutine color_init_from_array2g
@ %def color_init_from_array
@ Set the ghost property
<<Colors: color: TBP>>=
procedure :: set_ghost => color_set_ghost
<<Colors: sub interfaces>>=
elemental module subroutine color_set_ghost (col, ghost)
class(color_t), intent(inout) :: col
logical, intent(in) :: ghost
end subroutine color_set_ghost
<<Colors: procedures>>=
elemental module subroutine color_set_ghost (col, ghost)
class(color_t), intent(inout) :: col
logical, intent(in) :: ghost
col%ghost = ghost
end subroutine color_set_ghost
@ %def color_set_ghost
@ Undefine the color state:
<<Colors: color: TBP>>=
procedure :: undefine => color_undefine
<<Colors: sub interfaces>>=
elemental module subroutine color_undefine (col, undefine_ghost)
class(color_t), intent(inout) :: col
logical, intent(in), optional :: undefine_ghost
end subroutine color_undefine
<<Colors: procedures>>=
elemental module subroutine color_undefine (col, undefine_ghost)
class(color_t), intent(inout) :: col
logical, intent(in), optional :: undefine_ghost
col%defined = .false.
if (present (undefine_ghost)) then
if (undefine_ghost) col%ghost = .false.
else
col%ghost = .false.
end if
end subroutine color_undefine
@ %def color_undefine
@ Output. As dense as possible, no linebreak. If color is undefined,
no output.
The separate version for a color array suggest two distinct interfaces.
<<Colors: public>>=
public :: color_write
<<Colors: interfaces>>=
interface color_write
module procedure color_write_single
module procedure color_write_array
end interface color_write
<<Colors: color: TBP>>=
procedure :: write => color_write_single
<<Colors: sub interfaces>>=
module subroutine color_write_single (col, unit)
class(color_t), intent(in) :: col
integer, intent(in), optional :: unit
end subroutine color_write_single
module subroutine color_write_array (col, unit)
type(color_t), dimension(:), intent(in) :: col
integer, intent(in), optional :: unit
end subroutine color_write_array
<<Colors: procedures>>=
module subroutine color_write_single (col, unit)
class(color_t), intent(in) :: col
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
if (col%ghost) then
write (u, "(A)", advance="no") "c*"
else if (col%defined) then
write (u, "(A)", advance="no") "c("
if (col%c1(1) /= 0) write (u, "(I0)", advance="no") col%c1(1)
if (any (col%c1 /= 0)) write (u, "(1x)", advance="no")
if (col%c1(2) /= 0) write (u, "(I0)", advance="no") col%c1(2)
if (.not. col%is_diagonal ()) then
write (u, "(A)", advance="no") "|"
if (col%c2(1) /= 0) write (u, "(I0)", advance="no") col%c2(1)
if (any (col%c2 /= 0)) write (u, "(1x)", advance="no")
if (col%c2(2) /= 0) write (u, "(I0)", advance="no") col%c2(2)
end if
write (u, "(A)", advance="no") ")"
end if
end subroutine color_write_single
module subroutine color_write_array (col, unit)
type(color_t), dimension(:), intent(in) :: col
integer, intent(in), optional :: unit
integer :: u
integer :: i
u = given_output_unit (unit); if (u < 0) return
write (u, "(A)", advance="no") "["
do i = 1, size (col)
if (i > 1) write (u, "(1x)", advance="no")
call color_write_single (col(i), u)
end do
write (u, "(A)", advance="no") "]"
end subroutine color_write_array
@ %def color_write
@ Binary I/O. For allocatable colors, this would have to be modified.
<<Colors: color: TBP>>=
procedure :: write_raw => color_write_raw
procedure :: read_raw => color_read_raw
<<Colors: sub interfaces>>=
module subroutine color_write_raw (col, u)
class(color_t), intent(in) :: col
integer, intent(in) :: u
end subroutine color_write_raw
module subroutine color_read_raw (col, u, iostat)
class(color_t), intent(inout) :: col
integer, intent(in) :: u
integer, intent(out), optional :: iostat
end subroutine color_read_raw
<<Colors: procedures>>=
module subroutine color_write_raw (col, u)
class(color_t), intent(in) :: col
integer, intent(in) :: u
logical :: defined
defined = col%is_defined () .or. col%is_ghost ()
write (u) defined
if (defined) then
write (u) col%c1, col%c2
write (u) col%ghost
end if
end subroutine color_write_raw
module subroutine color_read_raw (col, u, iostat)
class(color_t), intent(inout) :: col
integer, intent(in) :: u
integer, intent(out), optional :: iostat
logical :: defined
read (u, iostat=iostat) col%defined
if (col%defined) then
read (u, iostat=iostat) col%c1, col%c2
read (u, iostat=iostat) col%ghost
end if
end subroutine color_read_raw
@ %def color_write_raw color_read_raw
@
\subsection{Predicates}
Return the definition status. A color state may be defined but trivial.
<<Colors: color: TBP>>=
procedure :: is_defined => color_is_defined
procedure :: is_nonzero => color_is_nonzero
<<Colors: sub interfaces>>=
elemental module function color_is_defined (col) result (defined)
logical :: defined
class(color_t), intent(in) :: col
end function color_is_defined
elemental module function color_is_nonzero (col) result (flag)
logical :: flag
class(color_t), intent(in) :: col
end function color_is_nonzero
<<Colors: procedures>>=
elemental module function color_is_defined (col) result (defined)
logical :: defined
class(color_t), intent(in) :: col
defined = col%defined
end function color_is_defined
elemental module function color_is_nonzero (col) result (flag)
logical :: flag
class(color_t), intent(in) :: col
flag = col%defined &
.and. .not. col%ghost &
.and. any (col%c1 /= 0 .or. col%c2 /= 0)
end function color_is_nonzero
@ %def color_is_defined
@ %def color_is_nonzero
@ Diagonal color objects have only one array allocated:
<<Colors: color: TBP>>=
procedure :: is_diagonal => color_is_diagonal
<<Colors: sub interfaces>>=
elemental module function color_is_diagonal (col) result (diagonal)
logical :: diagonal
class(color_t), intent(in) :: col
end function color_is_diagonal
<<Colors: procedures>>=
elemental module function color_is_diagonal (col) result (diagonal)
logical :: diagonal
class(color_t), intent(in) :: col
if (col%defined) then
diagonal = all (col%c1 == col%c2)
else
diagonal = .true.
end if
end function color_is_diagonal
@ %def color_is_diagonal
@ Return the ghost flag
<<Colors: color: TBP>>=
procedure :: is_ghost => color_is_ghost
<<Colors: sub interfaces>>=
elemental module function color_is_ghost (col) result (ghost)
logical :: ghost
class(color_t), intent(in) :: col
end function color_is_ghost
<<Colors: procedures>>=
elemental module function color_is_ghost (col) result (ghost)
logical :: ghost
class(color_t), intent(in) :: col
ghost = col%ghost
end function color_is_ghost
@ %def color_is_ghost
@ The ghost parity: true if the color-ghost flag is set. Again, no
TBP since this is an array.
<<Colors: procedures>>=
pure function color_ghost_parity (col) result (parity)
type(color_t), dimension(:), intent(in) :: col
logical :: parity
parity = mod (count (col%ghost), 2) == 1
end function color_ghost_parity
@ %def color_ghost_parity
@ Determine the color representation, given a color object. We allow
only singlet ($1$), (anti)triplet ($\pm 3$), and octet states ($8$).
A color ghost must not have color assigned, but the color type is $8$. For
non-diagonal color, representations must match. If the color type is
undefined, return $0$. If it is invalid or unsupported, return $-1$.
Assumption: nonzero entries precede nonzero ones.
<<Colors: color: TBP>>=
procedure :: get_type => color_get_type
<<Colors: sub interfaces>>=
elemental module function color_get_type (col) result (ctype)
class(color_t), intent(in) :: col
integer :: ctype
end function color_get_type
<<Colors: procedures>>=
elemental module function color_get_type (col) result (ctype)
class(color_t), intent(in) :: col
integer :: ctype
if (col%defined) then
ctype = -1
if (col%ghost) then
if (all (col%c1 == 0 .and. col%c2 == 0)) then
ctype = 8
end if
else
if (all ((col%c1 == 0 .and. col%c2 == 0) &
& .or. (col%c1 > 0 .and. col%c2 > 0) &
& .or. (col%c1 < 0 .and. col%c2 < 0))) then
if (all (col%c1 == 0)) then
ctype = 1
else if ((col%c1(1) > 0 .and. col%c1(2) == 0)) then
ctype = 3
else if ((col%c1(1) < 0 .and. col%c1(2) == 0)) then
ctype = -3
else if ((col%c1(1) > 0 .and. col%c1(2) < 0) &
.or.(col%c1(1) < 0 .and. col%c1(2) > 0)) then
ctype = 8
end if
end if
end if
else
ctype = 0
end if
end function color_get_type
@ %def color_get_type
@
\subsection{Accessing contents}
Return the number of color indices. We assume that it is identical
for both arrays.
<<Colors: color: TBP>>=
procedure, private :: get_number_of_indices => color_get_number_of_indices
<<Colors: sub interfaces>>=
elemental module function color_get_number_of_indices (col) result (n)
integer :: n
class(color_t), intent(in) :: col
end function color_get_number_of_indices
<<Colors: procedures>>=
elemental module function color_get_number_of_indices (col) result (n)
integer :: n
class(color_t), intent(in) :: col
if (col%defined .and. .not. col%ghost) then
n = count (col%c1 /= 0)
else
n = 0
end if
end function color_get_number_of_indices
@ %def color_get_number_of_indices
@ Return the (first) color/anticolor entry (assuming that color is
diagonal). The result is a positive color index.
<<Colors: color: TBP>>=
procedure :: get_col => color_get_col
procedure :: get_acl => color_get_acl
<<Colors: sub interfaces>>=
elemental module function color_get_col (col) result (c)
integer :: c
class(color_t), intent(in) :: col
end function color_get_col
elemental module function color_get_acl (col) result (c)
integer :: c
class(color_t), intent(in) :: col
end function color_get_acl
<<Colors: procedures>>=
elemental module function color_get_col (col) result (c)
integer :: c
class(color_t), intent(in) :: col
integer :: i
if (col%defined .and. .not. col%ghost) then
do i = 1, size (col%c1)
if (col%c1(i) > 0) then
c = col%c1(i)
return
end if
end do
end if
c = 0
end function color_get_col
elemental module function color_get_acl (col) result (c)
integer :: c
class(color_t), intent(in) :: col
integer :: i
if (col%defined .and. .not. col%ghost) then
do i = 1, size (col%c1)
if (col%c1(i) < 0) then
c = - col%c1(i)
return
end if
end do
end if
c = 0
end function color_get_acl
@ %def color_get_col color_get_acl
@ Return the color index with highest absolute value
<<Colors: public>>=
public :: color_get_max_value
<<Colors: interfaces>>=
interface color_get_max_value
module procedure color_get_max_value0
module procedure color_get_max_value1
module procedure color_get_max_value2
end interface color_get_max_value
<<Colors: sub interfaces>>=
elemental module function color_get_max_value0 (col) result (cmax)
integer :: cmax
type(color_t), intent(in) :: col
end function color_get_max_value0
pure module function color_get_max_value1 (col) result (cmax)
integer :: cmax
type(color_t), dimension(:), intent(in) :: col
end function color_get_max_value1
pure module function color_get_max_value2 (col) result (cmax)
integer :: cmax
type(color_t), dimension(:,:), intent(in) :: col
end function color_get_max_value2
<<Colors: procedures>>=
elemental module function color_get_max_value0 (col) result (cmax)
integer :: cmax
type(color_t), intent(in) :: col
if (col%defined .and. .not. col%ghost) then
cmax = maxval (abs (col%c1))
else
cmax = 0
end if
end function color_get_max_value0
pure module function color_get_max_value1 (col) result (cmax)
integer :: cmax
type(color_t), dimension(:), intent(in) :: col
cmax = maxval (color_get_max_value0 (col))
end function color_get_max_value1
pure module function color_get_max_value2 (col) result (cmax)
integer :: cmax
type(color_t), dimension(:,:), intent(in) :: col
integer, dimension(size(col, 2)) :: cm
integer :: i
forall (i = 1:size(col, 2))
cm(i) = color_get_max_value1 (col(:,i))
end forall
cmax = maxval (cm)
end function color_get_max_value2
@ %def color_get_max_value
@
\subsection{Comparisons}
Similar to helicities, colors match if they are equal, or if either
one is undefined.
<<Colors: color: TBP>>=
generic :: operator(.match.) => color_match
generic :: operator(==) => color_eq
generic :: operator(/=) => color_neq
procedure, private :: color_match
procedure, private :: color_eq
procedure, private :: color_neq
@ %def .match. == /=
<<Colors: sub interfaces>>=
elemental module function color_match (col1, col2) result (eq)
logical :: eq
class(color_t), intent(in) :: col1, col2
end function color_match
elemental module function color_eq (col1, col2) result (eq)
logical :: eq
class(color_t), intent(in) :: col1, col2
end function color_eq
<<Colors: procedures>>=
elemental module function color_match (col1, col2) result (eq)
logical :: eq
class(color_t), intent(in) :: col1, col2
if (col1%defined .and. col2%defined) then
if (col1%ghost .and. col2%ghost) then
eq = .true.
else if (.not. col1%ghost .and. .not. col2%ghost) then
eq = all (col1%c1 == col2%c1) .and. all (col1%c2 == col2%c2)
else
eq = .false.
end if
else
eq = .true.
end if
end function color_match
elemental module function color_eq (col1, col2) result (eq)
logical :: eq
class(color_t), intent(in) :: col1, col2
if (col1%defined .and. col2%defined) then
if (col1%ghost .and. col2%ghost) then
eq = .true.
else if (.not. col1%ghost .and. .not. col2%ghost) then
eq = all (col1%c1 == col2%c1) .and. all (col1%c2 == col2%c2)
else
eq = .false.
end if
else if (.not. col1%defined &
.and. .not. col2%defined) then
eq = col1%ghost .eqv. col2%ghost
else
eq = .false.
end if
end function color_eq
@ %def color_eq
<<Colors: sub interfaces>>=
elemental module function color_neq (col1, col2) result (neq)
logical :: neq
class(color_t), intent(in) :: col1, col2
end function color_neq
<<Colors: procedures>>=
elemental module function color_neq (col1, col2) result (neq)
logical :: neq
class(color_t), intent(in) :: col1, col2
if (col1%defined .and. col2%defined) then
if (col1%ghost .and. col2%ghost) then
neq = .false.
else if (.not. col1%ghost .and. .not. col2%ghost) then
neq = any (col1%c1 /= col2%c1) .or. any (col1%c2 /= col2%c2)
else
neq = .true.
end if
else if (.not. col1%defined &
.and. .not. col2%defined) then
neq = col1%ghost .neqv. col2%ghost
else
neq = .true.
end if
end function color_neq
@ %def color_neq
@
\subsection{Tools}
Shift color indices by a common offset.
<<Colors: color: TBP>>=
procedure :: add_offset => color_add_offset
<<Colors: sub interfaces>>=
elemental module subroutine color_add_offset (col, offset)
class(color_t), intent(inout) :: col
integer, intent(in) :: offset
end subroutine color_add_offset
<<Colors: procedures>>=
elemental module subroutine color_add_offset (col, offset)
class(color_t), intent(inout) :: col
integer, intent(in) :: offset
if (col%defined .and. .not. col%ghost) then
where (col%c1 /= 0) col%c1 = col%c1 + sign (offset, col%c1)
where (col%c2 /= 0) col%c2 = col%c2 + sign (offset, col%c2)
end if
end subroutine color_add_offset
@ %def color_add_offset
@ Reassign color indices for an array of colored particle in canonical
order. The allocated size of the color map is such that two colors
per particle can be accomodated.
The algorithm works directly on the contents of the color objects, it
<<Colors: public>>=
public :: color_canonicalize
<<Colors: sub interfaces>>=
module subroutine color_canonicalize (col)
type(color_t), dimension(:), intent(inout) :: col
end subroutine color_canonicalize
<<Colors: procedures>>=
module subroutine color_canonicalize (col)
type(color_t), dimension(:), intent(inout) :: col
integer, dimension(2*size(col)) :: map
integer :: n_col, i, j, k
n_col = 0
do i = 1, size (col)
if (col(i)%defined .and. .not. col(i)%ghost) then
do j = 1, size (col(i)%c1)
if (col(i)%c1(j) /= 0) then
k = find (abs (col(i)%c1(j)), map(:n_col))
if (k == 0) then
n_col = n_col + 1
map(n_col) = abs (col(i)%c1(j))
k = n_col
end if
col(i)%c1(j) = sign (k, col(i)%c1(j))
end if
if (col(i)%c2(j) /= 0) then
k = find (abs (col(i)%c2(j)), map(:n_col))
if (k == 0) then
n_col = n_col + 1
map(n_col) = abs (col(i)%c2(j))
k = n_col
end if
col(i)%c2(j) = sign (k, col(i)%c2(j))
end if
end do
end if
end do
contains
function find (c, array) result (k)
integer :: k
integer, intent(in) :: c
integer, dimension(:), intent(in) :: array
integer :: i
k = 0
do i = 1, size (array)
if (c == array (i)) then
k = i
return
end if
end do
end function find
end subroutine color_canonicalize
@ %def color_canonicalize
@ Return an array of different color indices from an array of colors.
The last argument is a pseudo-color array, where the color entries
correspond to the position of the corresponding index entry in the
index array. The colors are assumed to be diagonal.
The algorithm works directly on the contents of the color objects.
<<Colors: procedures>>=
subroutine extract_color_line_indices (col, c_index, col_pos)
type(color_t), dimension(:), intent(in) :: col
integer, dimension(:), intent(out), allocatable :: c_index
type(color_t), dimension(size(col)), intent(out) :: col_pos
integer, dimension(:), allocatable :: c_tmp
integer :: i, j, k, n, c
allocate (c_tmp (sum (col%get_number_of_indices ())), source=0)
n = 0
SCAN1: do i = 1, size (col)
if (col(i)%defined .and. .not. col(i)%ghost) then
SCAN2: do j = 1, 2
c = abs (col(i)%c1(j))
if (c /= 0) then
do k = 1, n
if (c_tmp(k) == c) then
col_pos(i)%c1(j) = k
cycle SCAN2
end if
end do
n = n + 1
c_tmp(n) = c
col_pos(i)%c1(j) = n
end if
end do SCAN2
end if
end do SCAN1
allocate (c_index (n))
c_index = c_tmp(1:n)
end subroutine extract_color_line_indices
@ %def extract_color_line_indices
@ Given a color array, pairwise contract the color lines in all
possible ways and return the resulting array of arrays. The input
color array must be diagonal, and each color should occur exactly
twice, once as color and once as anticolor.
Gluon entries with equal color and anticolor are explicitly excluded.
This algorithm is generic, but for long arrays it is neither
efficient, nor does it avoid duplicates. It is intended for small
arrays, in particular for the state matrix of a structure-function
pair.
The algorithm works directly on the contents of the color objects, it
thus depends on the implementation.
<<Colors: public>>=
public :: color_array_make_contractions
<<Colors: sub interfaces>>=
module subroutine color_array_make_contractions (col_in, col_out)
type(color_t), dimension(:), intent(in) :: col_in
type(color_t), dimension(:,:), intent(out), allocatable :: col_out
end subroutine color_array_make_contractions
<<Colors: procedures>>=
module subroutine color_array_make_contractions (col_in, col_out)
type(color_t), dimension(:), intent(in) :: col_in
type(color_t), dimension(:,:), intent(out), allocatable :: col_out
type(list_t) :: list
type(entry_t), pointer :: entry
integer, dimension(:), allocatable :: c_index
type(color_t), dimension(size(col_in)) :: col_pos
integer :: n_prt, n_c_index
integer, dimension(:), allocatable :: map
integer :: i, j, c
n_prt = size (col_in)
call extract_color_line_indices (col_in, c_index, col_pos)
n_c_index = size (c_index)
allocate (map (n_c_index))
map = 0
call list_append_if_valid (list, map)
entry => list%first
do while (associated (entry))
do i = 1, n_c_index
if (entry%map(i) == 0) then
c = c_index(i)
do j = i + 1, n_c_index
if (entry%map(j) == 0) then
map = entry%map
map(i) = c
map(j) = c
call list_append_if_valid (list, map)
end if
end do
end if
end do
entry => entry%next
end do
call list_to_array (list, col_out)
contains
subroutine list_append_if_valid (list, map)
type(list_t), intent(inout) :: list
integer, dimension(:), intent(in) :: map
type(entry_t), pointer :: entry
integer :: i, j, c, p
entry => list%first
do while (associated (entry))
if (all (map == entry%map)) return
entry => entry%next
end do
allocate (entry)
allocate (entry%map (n_c_index))
entry%map = map
allocate (entry%col (n_prt))
do i = 1, n_prt
do j = 1, 2
c = col_in(i)%c1(j)
if (c /= 0) then
p = col_pos(i)%c1(j)
entry%col(i)%defined = .true.
if (map(p) /= 0) then
entry%col(i)%c1(j) = sign (map(p), c)
else
entry%col(i)%c1(j) = c
endif
entry%col(i)%c2(j) = entry%col(i)%c1(j)
end if
end do
if (any (entry%col(i)%c1 /= 0) .and. &
entry%col(i)%c1(1) == - entry%col(i)%c1(2)) return
end do
if (associated (list%last)) then
list%last%next => entry
else
list%first => entry
end if
list%last => entry
list%n = list%n + 1
end subroutine list_append_if_valid
subroutine list_to_array (list, col)
type(list_t), intent(inout) :: list
type(color_t), dimension(:,:), intent(out), allocatable :: col
type(entry_t), pointer :: entry
integer :: i
allocate (col (n_prt, list%n - 1))
do i = 0, list%n - 1
entry => list%first
list%first => list%first%next
if (i /= 0) col(:,i) = entry%col
deallocate (entry)
end do
list%last => null ()
end subroutine list_to_array
end subroutine color_array_make_contractions
@ %def color_array_make_contractions
@ Invert the color index, switching from particle to antiparticle.
For gluons, we have to swap the order of color entries.
<<Colors: color: TBP>>=
procedure :: invert => color_invert
<<Colors: sub interfaces>>=
elemental module subroutine color_invert (col)
class(color_t), intent(inout) :: col
end subroutine color_invert
<<Colors: procedures>>=
elemental module subroutine color_invert (col)
class(color_t), intent(inout) :: col
if (col%defined .and. .not. col%ghost) then
col%c1 = - col%c1
col%c2 = - col%c2
if (col%c1(1) < 0 .and. col%c1(2) > 0) then
col%c1 = col%c1(2:1:-1)
col%c2 = col%c2(2:1:-1)
end if
end if
end subroutine color_invert
@ %def color_invert
@ Make a color map for two matching color arrays. The result is an
array of integer pairs.
<<Colors: public>>=
public :: make_color_map
<<Colors: interfaces>>=
interface make_color_map
module procedure color_make_color_map
end interface make_color_map
<<Colors: sub interfaces>>=
module subroutine color_make_color_map (map, col1, col2)
integer, dimension(:,:), intent(out), allocatable :: map
type(color_t), dimension(:), intent(in) :: col1, col2
end subroutine color_make_color_map
<<Colors: procedures>>=
module subroutine color_make_color_map (map, col1, col2)
integer, dimension(:,:), intent(out), allocatable :: map
type(color_t), dimension(:), intent(in) :: col1, col2
integer, dimension(:,:), allocatable :: map1
integer :: i, j, k
allocate (map1 (2, 2 * sum (col1%get_number_of_indices ())))
k = 0
do i = 1, size (col1)
if (col1(i)%defined .and. .not. col1(i)%ghost) then
do j = 1, size (col1(i)%c1)
if (col1(i)%c1(j) /= 0 &
.and. all (map1(1,:k) /= abs (col1(i)%c1(j)))) then
k = k + 1
map1(1,k) = abs (col1(i)%c1(j))
map1(2,k) = abs (col2(i)%c1(j))
end if
if (col1(i)%c2(j) /= 0 &
.and. all (map1(1,:k) /= abs (col1(i)%c2(j)))) then
k = k + 1
map1(1,k) = abs (col1(i)%c2(j))
map1(2,k) = abs (col2(i)%c2(j))
end if
end do
end if
end do
allocate (map (2, k))
map(:,:) = map1(:,:k)
end subroutine color_make_color_map
@ %def make_color_map
@ Translate colors which have a match in the translation table (an
array of integer pairs). Color that do not match an entry are simply
transferred; this is done by first transferring all components, then
modifiying entries where appropriate.
<<Colors: public>>=
public :: color_translate
<<Colors: interfaces>>=
interface color_translate
module procedure color_translate0
module procedure color_translate0_offset
module procedure color_translate1
end interface color_translate
<<Colors: sub interfaces>>=
module subroutine color_translate0 (col, map)
type(color_t), intent(inout) :: col
integer, dimension(:,:), intent(in) :: map
end subroutine color_translate0
module subroutine color_translate0_offset (col, map, offset)
type(color_t), intent(inout) :: col
integer, dimension(:,:), intent(in) :: map
integer, intent(in) :: offset
end subroutine color_translate0_offset
module subroutine color_translate1 (col, map, offset)
type(color_t), dimension(:), intent(inout) :: col
integer, dimension(:,:), intent(in) :: map
integer, intent(in), optional :: offset
end subroutine color_translate1
<<Colors: procedures>>=
module subroutine color_translate0 (col, map)
type(color_t), intent(inout) :: col
integer, dimension(:,:), intent(in) :: map
type(color_t) :: col_tmp
integer :: i
if (col%defined .and. .not. col%ghost) then
col_tmp = col
do i = 1, size (map,2)
where (abs (col%c1) == map(1,i))
col_tmp%c1 = sign (map(2,i), col%c1)
end where
where (abs (col%c2) == map(1,i))
col_tmp%c2 = sign (map(2,i), col%c2)
end where
end do
col = col_tmp
end if
end subroutine color_translate0
module subroutine color_translate0_offset (col, map, offset)
type(color_t), intent(inout) :: col
integer, dimension(:,:), intent(in) :: map
integer, intent(in) :: offset
logical, dimension(size(col%c1)) :: mask1, mask2
type(color_t) :: col_tmp
integer :: i
if (col%defined .and. .not. col%ghost) then
col_tmp = col
mask1 = col%c1 /= 0
mask2 = col%c2 /= 0
do i = 1, size (map,2)
where (abs (col%c1) == map(1,i))
col_tmp%c1 = sign (map(2,i), col%c1)
mask1 = .false.
end where
where (abs (col%c2) == map(1,i))
col_tmp%c2 = sign (map(2,i), col%c2)
mask2 = .false.
end where
end do
col = col_tmp
where (mask1) col%c1 = sign (abs (col%c1) + offset, col%c1)
where (mask2) col%c2 = sign (abs (col%c2) + offset, col%c2)
end if
end subroutine color_translate0_offset
module subroutine color_translate1 (col, map, offset)
type(color_t), dimension(:), intent(inout) :: col
integer, dimension(:,:), intent(in) :: map
integer, intent(in), optional :: offset
integer :: i
if (present (offset)) then
do i = 1, size (col)
call color_translate0_offset (col(i), map, offset)
end do
else
do i = 1, size (col)
call color_translate0 (col(i), map)
end do
end if
end subroutine color_translate1
@ %def color_translate
@ Merge two color objects by taking the first entry from the first and
the first entry from the second argument. Makes sense only if the
input colors are defined (and diagonal). If either one is undefined,
transfer the defined one.
<<Colors: color: TBP>>=
generic :: operator(.merge.) => merge_colors
procedure, private :: merge_colors
@ %def .merge.
<<Colors: sub interfaces>>=
elemental module function merge_colors (col1, col2) result (col)
type(color_t) :: col
class(color_t), intent(in) :: col1, col2
end function merge_colors
<<Colors: procedures>>=
elemental module function merge_colors (col1, col2) result (col)
type(color_t) :: col
class(color_t), intent(in) :: col1, col2
if (color_is_defined (col1) .and. color_is_defined (col2)) then
if (color_is_ghost (col1) .and. color_is_ghost (col2)) then
call color_init_trivial_ghost (col, .true.)
else
call color_init_arrays (col, col1%c1, col2%c1)
end if
else if (color_is_defined (col1)) then
call color_init_array (col, col1%c1)
else if (color_is_defined (col2)) then
call color_init_array (col, col2%c1)
end if
end function merge_colors
@ %def merge_colors
@ Merge up to two (diagonal!) color objects. The result inherits the unmatched
color lines of the input colors. If one of the input colors is
undefined, the output is undefined as well. It must be in a supported
color representation.
A color-ghost object should not actually occur in real-particle
events, but for completeness we define its behavior. For simplicity,
it is identified as a color-octet with zero color/anticolor. It can
only couple to a triplet or antitriplet. A fusion of triplet with
matching antitriplet will yield a singlet, not a ghost, however.
If the fusion fails, the result is undefined.
<<Colors: color: TBP>>=
generic :: operator (.fuse.) => color_fusion
procedure, private :: color_fusion
<<Colors: sub interfaces>>=
module function color_fusion (col1, col2) result (col)
class(color_t), intent(in) :: col1, col2
type(color_t) :: col
end function color_fusion
<<Colors: procedures>>=
module function color_fusion (col1, col2) result (col)
class(color_t), intent(in) :: col1, col2
type(color_t) :: col
integer, dimension(2) :: ctype
if (col1%is_defined () .and. col2%is_defined ()) then
if (col1%is_diagonal () .and. col2%is_diagonal ()) then
ctype = [col1%get_type (), col2%get_type ()]
select case (ctype(1))
case (1)
select case (ctype(2))
case (1,3,-3,8)
col = col2
end select
case (3)
select case (ctype(2))
case (1)
col = col1
case (-3)
call t_a (col1%get_col (), col2%get_acl ())
case (8)
call t_o (col1%get_col (), col2%get_acl (), &
& col2%get_col ())
end select
case (-3)
select case (ctype(2))
case (1)
col = col1
case (3)
call t_a (col2%get_col (), col1%get_acl ())
case (8)
call a_o (col1%get_acl (), col2%get_col (), &
& col2%get_acl ())
end select
case (8)
select case (ctype(2))
case (1)
col = col1
case (3)
call t_o (col2%get_col (), col1%get_acl (), &
& col1%get_col ())
case (-3)
call a_o (col2%get_acl (), col1%get_col (), &
& col1%get_acl ())
case (8)
call o_o (col1%get_col (), col1%get_acl (), &
& col2%get_col (), col2%get_acl ())
end select
end select
end if
end if
contains
subroutine t_a (c1, c2)
integer, intent(in) :: c1, c2
if (c1 == c2) then
call col%init_col_acl (0, 0)
else
call col%init_col_acl (c1, c2)
end if
end subroutine t_a
subroutine t_o (c1, c2, c3)
integer, intent(in) :: c1, c2, c3
if (c1 == c2) then
call col%init_col_acl (c3, 0)
else if (c2 == 0 .and. c3 == 0) then
call col%init_col_acl (c1, 0)
end if
end subroutine t_o
subroutine a_o (c1, c2, c3)
integer, intent(in) :: c1, c2, c3
if (c1 == c2) then
call col%init_col_acl (0, c3)
else if (c2 == 0 .and. c3 == 0) then
call col%init_col_acl (0, c1)
end if
end subroutine a_o
subroutine o_o (c1, c2, c3, c4)
integer, intent(in) :: c1, c2, c3, c4
if (all ([c1,c2,c3,c4] /= 0)) then
if (c2 == c3 .and. c4 == c1) then
call col%init_col_acl (0, 0)
else if (c2 == c3) then
call col%init_col_acl (c1, c4)
else if (c4 == c1) then
call col%init_col_acl (c3, c2)
end if
end if
end subroutine o_o
end function color_fusion
@ %def color_fusion
@ Compute the color factor, given two interfering color arrays.
<<Colors: public>>=
public :: compute_color_factor
<<Colors: sub interfaces>>=
module function compute_color_factor (col1, col2, nc) result (factor)
real(default) :: factor
type(color_t), dimension(:), intent(in) :: col1, col2
integer, intent(in), optional :: nc
end function compute_color_factor
<<Colors: procedures>>=
module function compute_color_factor (col1, col2, nc) result (factor)
real(default) :: factor
type(color_t), dimension(:), intent(in) :: col1, col2
integer, intent(in), optional :: nc
type(color_t), dimension(size(col1)) :: col
integer :: ncol, nloops, nghost
ncol = 3; if (present (nc)) ncol = nc
col = col1 .merge. col2
nloops = count_color_loops (col)
nghost = count (col%is_ghost ())
factor = real (ncol, default) ** (nloops - nghost)
if (color_ghost_parity (col)) factor = - factor
end function compute_color_factor
@ %def compute_color_factor
@
We have a pair of color index arrays which corresponds to a squared
matrix element. We want to determine the number of color loops in
this square matrix element. So we first copy the colors (stored in a
single color array with a pair of color lists in each entry) to a
temporary where the color indices are shifted by some offset. We then
recursively follow each loop, starting at the first color that has the
offset, resetting the first color index to the loop index and each
further index to zero as we go. We check that (a) each color index
occurs twice within the left (right) color array, (b) the loops are
closed, so we always come back to a line which has the loop index.
In order for the algorithm to work we have to conjugate the colors of
initial state particles (one for decays, two for scatterings) into
their corresponding anticolors of outgoing particles.
<<Colors: public>>=
public :: count_color_loops
<<Colors: sub interfaces>>=
module function count_color_loops (col) result (count)
integer :: count
type(color_t), dimension(:), intent(in) :: col
end function count_color_loops
<<Colors: procedures>>=
module function count_color_loops (col) result (count)
integer :: count
type(color_t), dimension(:), intent(in) :: col
type(color_t), dimension(size(col)) :: cc
integer :: i, n, offset
cc = col
n = size (cc)
offset = n
call color_add_offset (cc, offset)
count = 0
SCAN_LOOPS: do
do i = 1, n
if (color_is_nonzero (cc(i))) then
if (any (cc(i)%c1 > offset)) then
count = count + 1
call follow_line1 (pick_new_line (cc(i)%c1, count, 1))
cycle SCAN_LOOPS
end if
end if
end do
exit SCAN_LOOPS
end do SCAN_LOOPS
contains
function pick_new_line (c, reset_val, sgn) result (line)
integer :: line
integer, dimension(:), intent(inout) :: c
integer, intent(in) :: reset_val
integer, intent(in) :: sgn
integer :: i
if (any (c == count)) then
line = count
else
do i = 1, size (c)
if (sign (1, c(i)) == sgn .and. abs (c(i)) > offset) then
line = c(i)
c(i) = reset_val
return
end if
end do
call color_mismatch
end if
end function pick_new_line
subroutine reset_line (c, line)
integer, dimension(:), intent(inout) :: c
integer, intent(in) :: line
integer :: i
do i = 1, size (c)
if (c(i) == line) then
c(i) = 0
return
end if
end do
end subroutine reset_line
recursive subroutine follow_line1 (line)
integer, intent(in) :: line
integer :: i
if (line == count) return
do i = 1, n
if (any (cc(i)%c1 == -line)) then
call reset_line (cc(i)%c1, -line)
call follow_line2 (pick_new_line (cc(i)%c2, 0, sign (1, -line)))
return
end if
end do
call color_mismatch ()
end subroutine follow_line1
recursive subroutine follow_line2 (line)
integer, intent(in) :: line
integer :: i
do i = 1, n
if (any (cc(i)%c2 == -line)) then
call reset_line (cc(i)%c2, -line)
call follow_line1 (pick_new_line (cc(i)%c1, 0, sign (1, -line)))
return
end if
end do
call color_mismatch ()
end subroutine follow_line2
subroutine color_mismatch ()
call color_write (col)
print *
call msg_fatal ("Color flow mismatch: Non-closed color lines appear during ", &
[var_str ("the evaluation of color correlations. This can happen if there "), &
var_str ("are different color structures in the initial or final state of "), &
var_str ("the process definition. If so, please use separate processes for "), &
var_str ("the different initial / final states. In a future WHIZARD version "), &
var_str ("this will be fixed.")])
end subroutine color_mismatch
end function count_color_loops
@ %def count_color_loops
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[colors_ut.f90]]>>=
<<File header>>
module colors_ut
use unit_tests
use colors_uti
<<Standard module head>>
<<Colors: public test>>
contains
<<Colors: test driver>>
end module colors_ut
@ %def colors_ut
@
<<[[colors_uti.f90]]>>=
<<File header>>
module colors_uti
use colors
<<Standard module head>>
<<Colors: test declarations>>
contains
<<Colors: tests>>
end module colors_uti
@ %def colors_ut
@ API: driver for the unit tests below.
<<Colors: public test>>=
public :: color_test
<<Colors: test driver>>=
subroutine color_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Colors: execute tests>>
end subroutine color_test
@ %def color_test
@ This is a color counting test.
<<Colors: execute tests>>=
call test (color_1, "color_1", &
"check color counting", &
u, results)
<<Colors: test declarations>>=
public :: color_1
<<Colors: tests>>=
subroutine color_1 (u)
integer, intent(in) :: u
type(color_t), dimension(4) :: col1, col2, col
type(color_t), dimension(:), allocatable :: col3
type(color_t), dimension(:,:), allocatable :: col_array
integer :: count, i
call col1%init_col_acl ([1, 0, 2, 3], [0, 1, 3, 2])
col2 = col1
call color_write (col1, u)
write (u, "(A)")
call color_write (col2, u)
write (u, "(A)")
col = col1 .merge. col2
call color_write (col, u)
write (u, "(A)")
count = count_color_loops (col)
write (u, "(A,I1)") "Number of color loops (3): ", count
call col2%init_col_acl ([1, 0, 2, 3], [0, 2, 3, 1])
call color_write (col1, u)
write (u, "(A)")
call color_write (col2, u)
write (u, "(A)")
col = col1 .merge. col2
call color_write (col, u)
write (u, "(A)")
count = count_color_loops (col)
write (u, "(A,I1)") "Number of color loops (2): ", count
write (u, "(A)")
allocate (col3 (4))
call color_init_from_array (col3, &
reshape ([1, 0, 0, -1, 2, -3, 3, -2], &
[2, 4]))
call color_write (col3, u)
write (u, "(A)")
call color_array_make_contractions (col3, col_array)
write (u, "(A)") "Contractions:"
do i = 1, size (col_array, 2)
call color_write (col_array(:,i), u)
write (u, "(A)")
end do
deallocate (col3)
write (u, "(A)")
allocate (col3 (6))
call color_init_from_array (col3, &
reshape ([1, -2, 3, 0, 0, -1, 2, -4, -3, 0, 4, 0], &
[2, 6]))
call color_write (col3, u)
write (u, "(A)")
call color_array_make_contractions (col3, col_array)
write (u, "(A)") "Contractions:"
do i = 1, size (col_array, 2)
call color_write (col_array(:,i), u)
write (u, "(A)")
end do
end subroutine color_1
@ %def color_1
@ A color fusion test.
<<Colors: execute tests>>=
call test (color_2, "color_2", &
"color fusion", &
u, results)
<<Colors: test declarations>>=
public :: color_2
<<Colors: tests>>=
subroutine color_2 (u)
integer, intent(in) :: u
type(color_t) :: s1, t1, t2, a1, a2, o1, o2, o3, o4, g1
write (u, "(A)") "* Test output: color_2"
write (u, "(A)") "* Purpose: test all combinations for color-object fusion"
write (u, "(A)")
call s1%init_col_acl (0,0)
call t1%init_col_acl (1,0)
call t2%init_col_acl (2,0)
call a1%init_col_acl (0,1)
call a2%init_col_acl (0,2)
call o1%init_col_acl (1,2)
call o2%init_col_acl (1,3)
call o3%init_col_acl (2,3)
call o4%init_col_acl (2,1)
call g1%init (ghost=.true.)
call wrt ("s1", s1)
call wrt ("t1", t1)
call wrt ("t2", t2)
call wrt ("a1", a1)
call wrt ("a2", a2)
call wrt ("o1", o1)
call wrt ("o2", o2)
call wrt ("o3", o3)
call wrt ("o4", o4)
call wrt ("g1", g1)
write (u, *)
call wrt ("s1 * s1", s1 .fuse. s1)
write (u, *)
call wrt ("s1 * t1", s1 .fuse. t1)
call wrt ("s1 * a1", s1 .fuse. a1)
call wrt ("s1 * o1", s1 .fuse. o1)
write (u, *)
call wrt ("t1 * s1", t1 .fuse. s1)
call wrt ("a1 * s1", a1 .fuse. s1)
call wrt ("o1 * s1", o1 .fuse. s1)
write (u, *)
call wrt ("t1 * t1", t1 .fuse. t1)
write (u, *)
call wrt ("t1 * t2", t1 .fuse. t2)
call wrt ("t1 * a1", t1 .fuse. a1)
call wrt ("t1 * a2", t1 .fuse. a2)
call wrt ("t1 * o1", t1 .fuse. o1)
call wrt ("t2 * o1", t2 .fuse. o1)
write (u, *)
call wrt ("t2 * t1", t2 .fuse. t1)
call wrt ("a1 * t1", a1 .fuse. t1)
call wrt ("a2 * t1", a2 .fuse. t1)
call wrt ("o1 * t1", o1 .fuse. t1)
call wrt ("o1 * t2", o1 .fuse. t2)
write (u, *)
call wrt ("a1 * a1", a1 .fuse. a1)
write (u, *)
call wrt ("a1 * a2", a1 .fuse. a2)
call wrt ("a1 * o1", a1 .fuse. o1)
call wrt ("a2 * o2", a2 .fuse. o2)
write (u, *)
call wrt ("a2 * a1", a2 .fuse. a1)
call wrt ("o1 * a1", o1 .fuse. a1)
call wrt ("o2 * a2", o2 .fuse. a2)
write (u, *)
call wrt ("o1 * o1", o1 .fuse. o1)
write (u, *)
call wrt ("o1 * o2", o1 .fuse. o2)
call wrt ("o1 * o3", o1 .fuse. o3)
call wrt ("o1 * o4", o1 .fuse. o4)
write (u, *)
call wrt ("o2 * o1", o2 .fuse. o1)
call wrt ("o3 * o1", o3 .fuse. o1)
call wrt ("o4 * o1", o4 .fuse. o1)
write (u, *)
call wrt ("g1 * g1", g1 .fuse. g1)
write (u, *)
call wrt ("g1 * s1", g1 .fuse. s1)
call wrt ("g1 * t1", g1 .fuse. t1)
call wrt ("g1 * a1", g1 .fuse. a1)
call wrt ("g1 * o1", g1 .fuse. o1)
write (u, *)
call wrt ("s1 * g1", s1 .fuse. g1)
call wrt ("t1 * g1", t1 .fuse. g1)
call wrt ("a1 * g1", a1 .fuse. g1)
call wrt ("o1 * g1", o1 .fuse. g1)
write (u, "(A)")
write (u, "(A)") "* Test output end: color_2"
contains
subroutine wrt (s, col)
character(*), intent(in) :: s
class(color_t), intent(in) :: col
write (u, "(A,1x,'=',1x)", advance="no") s
call col%write (u)
write (u, *)
end subroutine wrt
end subroutine color_2
@ %def color_2
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\subsection{The Madgraph color model}
This section describes the method for matrix element and color
flow calculation within Madgraph.
For each Feynman diagram, the colorless amplitude for a specified
helicity and momentum configuration (in- and out- combined) is
computed:
\begin{equation}
A_d(p,h)
\end{equation}
Inserting color, the squared matrix element for definite helicity and
momentum is
\begin{equation}
M^2(p,h) = \sum_{dd'} A_{d}(p,h)\,C_{dd'} A_{d'}^*(p,h)
\end{equation}
where $C_{dd'}$ describes the color interference of the two diagrams
$A_d$ and $A_d'$, which is independent of momentum and helicity and
can be calculated for each Feynman diagram pair by reducing it to the
corresponding color graph. Obviously, one could combine all diagrams
with identical color structure, such that the index $d$ runs only over
different color graphs. For colorless diagrams all elements of
$C_{dd'}$ are equal to unity.
The hermitian matrix $C_{dd'}$ is diagonalized once and for all, such
that it can be written in the form
\begin{equation}
C_{dd'} = \sum_\lambda c_d^\lambda \lambda\, c_d^\lambda{}^*,
\end{equation}
where the eigenvectors $c_d$ are normalized,
\begin{equation}
\sum_d |c_d^\lambda|^2 = 1,
\end{equation}
and the $\lambda$ values are the corresponding eigenvalues. In the
colorless case, this means $c_d = 1/\sqrt{N_d}$ for all diagrams
($N_d=$ number of diagrams), and $\lambda=N_d$ is the only nonzero
eigenvalue.
Consequently, the squared matrix element for definite helicity and
momentum can also be written as
\begin{equation}
M^2(p,h) = \sum_\lambda A_\lambda(p,h)\, \lambda\, A_\lambda(p,h)^*
\end{equation}
with
\begin{equation}
A_\lambda(p,h) = \sum_d c_d^\lambda A_d(p,h).
\end{equation}
For generic spin density matrices, this is easily generalized to
\begin{equation}
M^2(p,h,h') = \sum_\lambda A_\lambda(p,h)\, \lambda\, A_\lambda(p,h')^*
\end{equation}
To determine the color flow probabilities of a given momentum-helicity
configuration, the color flow amplitudes are calculated as
\begin{equation}
a_f(p,h) = \sum_d \beta^f_d A_d(p,h),
\end{equation}
where the coefficients $\beta^f_d$ describe the amplitude for a given
Feynman diagram (or color graph) $d$ to correspond to a definite color
flow~$f$. They are computed from $C_{dd'}$ by transforming this
matrix into the color flow basis and neglecting all off-diagonal
elements. Again, these coefficients do not depend on momentum or
helicity and can therefore be calculated in advance. This gives the
color flow transition matrix
\begin{equation}
F^f(p,h,h') = a_f(p,h)\, a^*_f(p,h')
\end{equation}
which is assumed diagonal in color flow space and is separate from the
color-summed transition matrix $M^2$. They are, however, equivalent
(up to a factor) to leading order in $1/N_c$, and using the color flow
transition matrix is appropriate for matching to hadronization.
Note that the color flow transition matrix is not normalized at this
stage. To make use of it, we have to fold it with the in-state
density matrix to get a pseudo density matrix
\begin{equation}
\hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})
= \sum_{h_{\rm in} h'_{\rm in}} F^f(p,h,h')\,
\rho_{\rm in}(p,h_{\rm in},h'_{\rm in})
\end{equation}
which gets a meaning only after contracted with projections on the
outgoing helicity states $k_{\rm out}$, given as linear combinations
of helicity states with the unitary coefficient matrix $c(k_{\rm out},
h_{\rm out})$. Then the probability of finding color flow $f$ when
the helicity state $k_{\rm out}$ is measured is given by
\begin{equation}
P^f(p, k_{\rm out}) = Q^f(p, k_{\rm out}) / \sum_f Q^f(p, k_{\rm out})
\end{equation}
where
\begin{equation}
Q^f(p, k_{\rm out}) = \sum_{h_{\rm out} h'_{\rm out}}
c(k_{\rm out}, h_{\rm out})\,
\hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})\,
c^*(k_{\rm out}, h'_{\rm out})
\end{equation}
However, if we can assume that the out-state helicity basis is the
canonical one, we can throw away the off diagonal elements in the
color flow density matrix and normalize the ones on the diagonal to obtain
\begin{equation}
P^f(p, h_{\rm out}) =
\hat\rho_{\rm out}^f(p,h_{\rm out},h_{\rm out}) /
\sum_f \hat\rho_{\rm out}^f(p,h_{\rm out},h_{\rm out})
\end{equation}
Finally, the color-summed out-state density matrix is computed by the
scattering formula
\begin{align}
{\rho_{\rm out}(p,h_{\rm out},h'_{\rm out})}
&=
\sum_{h_{\rm in} h'_{\rm in}} M^2(p,h,h')\,
\rho_{\rm in}(p,h_{\rm in},h'_{\rm in}) \\
&= \sum_{h_{\rm in} h'_{\rm in} \lambda}
A_\lambda(p,h)\, \lambda\, A_\lambda(p,h')^*
\rho_{\rm in}(p,h_{\rm in},h'_{\rm in}),
\end{align}
The trace of $\rho_{\rm out}$ is the squared matrix element, summed
over all internal degrees of freedom. To get the squared matrix
element for a definite helicity $k_{\rm out}$ and color flow $f$, one
has to project the density matrix onto the given helicity state and
multiply with $P^f(p, k_{\rm out})$.
For diagonal helicities the out-state density reduces to
\begin{equation}
\rho_{\rm out}(p,h_{\rm out})
= \sum_{h_{\rm in}\lambda}
\lambda|A_\lambda(p,h)|^2 \rho_{\rm in}(p,h_{\rm in}).
\end{equation}
Since no basis transformation is involved, we can use the normalized
color flow probability $P^f(p, h_{\rm out})$ and express the result as
\begin{align}
\rho_{\rm out}^f(p,h_{\rm out})
&= \rho_{\rm out}(p,h_{\rm out})\,P^f(p, h_{\rm out}) \\
&= \sum_{h_{\rm in}\lambda}
\frac{|a^f(p,h)|^2}{\sum_f|a^f(p,h)|^2}
\lambda|A_\lambda(p,h)|^2 \rho_{\rm in}(p,h_{\rm in}).
\end{align}
From these considerations, the following calculation strategy can be
derived:
\begin{itemize}
\item
Before the first event is generated, the color interference matrix
$C_{dd'}$ is computed and diagonalized, so the eigenvectors
$c^\lambda_d$, eigenvalues $\lambda$ and color flow coefficients
$\beta^f_d$ are obtained. In practice, these calculations are
done when the matrix element code is generated, and the results are
hardcoded in the matrix element subroutine as [[DATA]] statements.
\item
For each event, one loops over helicities once and stores the
matrices $A_\lambda(p,h)$ and $a^f(p,h)$. The allowed color flows,
helicity combinations and eigenvalues are each labeled by integer
indices, so one has to store complex matrices of dimension
$N_\lambda\times N_h$ and $N_f\times N_h$, respectively.
\item
The further strategy depends on the requested information.
\begin{enumerate}
\item
If colorless diagonal helicity amplitudes are required, the
eigenvalues $A_\lambda(p,h)$ are squared, summed with weight
$\lambda$, and the result contracted with the in-state probability
vector $\rho_{\rm in}(p, h_{\rm in})$. The result is a
probability vector $\rho_{\rm out}(p, h_{\rm out})$.
\item
For colored diagonal helicity amplitudes, the color coefficients
$a^f(p,h)$ are also squared and used as weights to obtain the color-flow
probability vector $\rho_{\rm out}^f(p, h_{\rm out})$.
\item
For colorless non-diagonal helicity amplitudes, we contract the
tensor product of $A_\lambda(p,h)$ with $A_\lambda(p,h')$,
weighted with $\lambda$, with the correlated in-state density
matrix, to obtain a correlated out-state density matrix.
\item
In the general (colored, non-diagonal) case, we do the same as
in the colorless case, but return the un-normalized color flow
density matrix $\hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})$
in addition. When the relevant helicity basis is known, the
latter can be used by the caller program to determine flow
probabilities. (In reality, we assume the canonical basis and
reduce the correlated out-state density to its diagonal immediately.)
\end{enumerate}
\end{itemize}
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Flavors: Particle properties}
This module contains a type for holding the flavor code, and all
functions that depend on the model, i.e., that determine particle
properties.
The PDG code is packed in a special [[flavor]] type. (This prohibits
meaningless operations, and it allows for a different implementation,
e.g., some non-PDG scheme internally, if appropiate at some point.)
There are lots of further particle properties that depend on the
model. Implementing a flyweight pattern, the associated field data
object is to be stored in a central area, the [[flavor]] object just
receives a pointer to this, so all queries can be delegated.
<<[[flavors.f90]]>>=
<<File header>>
module flavors
<<Use kinds>>
<<Use strings>>
use physics_defs, only: UNDEFINED
use model_data
use colors, only: color_t
<<Standard module head>>
<<Flavors: public>>
<<Flavors: types>>
<<Flavors: interfaces>>
interface
<<Flavors: sub interfaces>>
end interface
end module flavors
@ %def flavors
@
<<[[flavors_sub.f90]]>>=
<<File header>>
submodule (flavors) flavors_s
use io_units
use diagnostics
use physics_defs, only: INVALID
use physics_defs, only: HADRON_REMNANT
use physics_defs, only: HADRON_REMNANT_SINGLET
use physics_defs, only: HADRON_REMNANT_TRIPLET
use physics_defs, only: HADRON_REMNANT_OCTET
implicit none
contains
<<Flavors: procedures>>
end submodule flavors_s
@ %def flavors_s
@
\subsection{The flavor type}
The flavor type is an integer representing the PDG code, or
undefined (zero). Negative codes represent antiflavors. They should
be used only for particles which do have a distinct antiparticle.
The [[hard_process]] flag can be set for particles that are participating in
the hard interaction.
The [[radiated]] flag can be set for particles that are the result of
a beam-structure interaction (hadron beam remnant, ISR photon, etc.),
not of the hard interaction itself.
Further properties of the given flavor can be retrieved via the
particle-data pointer, if it is associated.
<<Flavors: public>>=
public :: flavor_t
<<Flavors: types>>=
type :: flavor_t
private
integer :: f = UNDEFINED
logical :: hard_process = .false.
logical :: radiated = .false.
type(field_data_t), pointer :: field_data => null ()
contains
<<Flavors: flavor: TBP>>
end type flavor_t
@ %def flavor_t
@ Initializer form. If the model is assigned, the procedure is
impure, therefore we have to define a separate array version.
Note: The pure elemental subroutines can't have an intent(out) CLASS
argument (because of the potential for an impure finalizer in a type
extension), so we stick to intent(inout) and (re)set all components
explicitly.
<<Flavors: flavor: TBP>>=
generic :: init => &
flavor_init_empty, &
flavor_init, &
flavor_init_field_data, &
flavor_init_model, &
flavor_init_model_alt, &
flavor_init_name_model
procedure, private :: flavor_init_empty
procedure, private :: flavor_init
procedure, private :: flavor_init_field_data
procedure, private :: flavor_init_model
procedure, private :: flavor_init_model_alt
procedure, private :: flavor_init_name_model
<<Flavors: sub interfaces>>=
elemental module subroutine flavor_init_empty (flv)
class(flavor_t), intent(inout) :: flv
end subroutine flavor_init_empty
elemental module subroutine flavor_init (flv, f)
class(flavor_t), intent(inout) :: flv
integer, intent(in) :: f
end subroutine flavor_init
impure elemental module subroutine flavor_init_field_data (flv, field_data)
class(flavor_t), intent(inout) :: flv
type(field_data_t), intent(in), target :: field_data
end subroutine flavor_init_field_data
impure elemental module subroutine flavor_init_model (flv, f, model)
class(flavor_t), intent(inout) :: flv
integer, intent(in) :: f
class(model_data_t), intent(in), target :: model
end subroutine flavor_init_model
impure elemental module subroutine flavor_init_model_alt (flv, f, model, alt_model)
class(flavor_t), intent(inout) :: flv
integer, intent(in) :: f
class(model_data_t), intent(in), target :: model, alt_model
end subroutine flavor_init_model_alt
impure elemental module subroutine flavor_init_name_model (flv, name, model)
class(flavor_t), intent(inout) :: flv
type(string_t), intent(in) :: name
class(model_data_t), intent(in), target :: model
end subroutine flavor_init_name_model
<<Flavors: procedures>>=
elemental module subroutine flavor_init_empty (flv)
class(flavor_t), intent(inout) :: flv
flv%f = UNDEFINED
flv%hard_process = .false.
flv%radiated = .false.
flv%field_data => null ()
end subroutine flavor_init_empty
elemental module subroutine flavor_init (flv, f)
class(flavor_t), intent(inout) :: flv
integer, intent(in) :: f
flv%f = f
flv%hard_process = .false.
flv%radiated = .false.
flv%field_data => null ()
end subroutine flavor_init
impure elemental module subroutine flavor_init_field_data (flv, field_data)
class(flavor_t), intent(inout) :: flv
type(field_data_t), intent(in), target :: field_data
flv%f = field_data%get_pdg ()
flv%hard_process = .false.
flv%radiated = .false.
flv%field_data => field_data
end subroutine flavor_init_field_data
impure elemental module subroutine flavor_init_model (flv, f, model)
class(flavor_t), intent(inout) :: flv
integer, intent(in) :: f
class(model_data_t), intent(in), target :: model
flv%f = f
flv%hard_process = .false.
flv%radiated = .false.
flv%field_data => model%get_field_ptr (f, check=.true.)
end subroutine flavor_init_model
impure elemental module subroutine flavor_init_model_alt (flv, f, model, alt_model)
class(flavor_t), intent(inout) :: flv
integer, intent(in) :: f
class(model_data_t), intent(in), target :: model, alt_model
flv%f = f
flv%hard_process = .false.
flv%radiated = .false.
flv%field_data => model%get_field_ptr (f, check=.false.)
if (.not. associated (flv%field_data)) then
flv%field_data => alt_model%get_field_ptr (f, check=.false.)
if (.not. associated (flv%field_data)) then
write (msg_buffer, "(A,1x,I0,1x,A,1x,A,1x,A,1x,A)") &
"Particle with code", f, &
"found neither in model", char (model%get_name ()), &
"nor in model", char (alt_model%get_name ())
call msg_fatal ()
end if
end if
end subroutine flavor_init_model_alt
impure elemental module subroutine flavor_init_name_model (flv, name, model)
class(flavor_t), intent(inout) :: flv
type(string_t), intent(in) :: name
class(model_data_t), intent(in), target :: model
flv%f = model%get_pdg (name)
flv%hard_process = .false.
flv%radiated = .false.
flv%field_data => model%get_field_ptr (name, check=.true.)
end subroutine flavor_init_name_model
@ %def flavor_init
@ Set the [[radiated]] flag.
<<Flavors: flavor: TBP>>=
procedure :: tag_radiated => flavor_tag_radiated
<<Flavors: sub interfaces>>=
elemental module subroutine flavor_tag_radiated (flv)
class(flavor_t), intent(inout) :: flv
end subroutine flavor_tag_radiated
<<Flavors: procedures>>=
elemental module subroutine flavor_tag_radiated (flv)
class(flavor_t), intent(inout) :: flv
flv%radiated = .true.
end subroutine flavor_tag_radiated
@ %def flavor_tag_radiated
@ Set the [[hard_process]] flag.
<<Flavors: flavor: TBP>>=
procedure :: tag_hard_process => flavor_tag_hard_process
<<Flavors: sub interfaces>>=
elemental module subroutine flavor_tag_hard_process (flv, hard)
class(flavor_t), intent(inout) :: flv
logical, intent(in), optional :: hard
end subroutine flavor_tag_hard_process
<<Flavors: procedures>>=
elemental module subroutine flavor_tag_hard_process (flv, hard)
class(flavor_t), intent(inout) :: flv
logical, intent(in), optional :: hard
if (present (hard)) then
flv%hard_process = hard
else
flv%hard_process = .true.
end if
end subroutine flavor_tag_hard_process
@ %def flavor_tag_hard_process
@ Undefine the flavor state:
<<Flavors: flavor: TBP>>=
procedure :: undefine => flavor_undefine
<<Flavors: sub interfaces>>=
elemental module subroutine flavor_undefine (flv)
class(flavor_t), intent(inout) :: flv
end subroutine flavor_undefine
<<Flavors: procedures>>=
elemental module subroutine flavor_undefine (flv)
class(flavor_t), intent(inout) :: flv
flv%f = UNDEFINED
flv%field_data => null ()
end subroutine flavor_undefine
@ %def flavor_undefine
@ Output: dense, no linebreak
A hard-process tag is only shown if debugging is on.
<<Flavors: flavor: TBP>>=
procedure :: write => flavor_write
<<Flavors: sub interfaces>>=
module subroutine flavor_write (flv, unit)
class(flavor_t), intent(in) :: flv
integer, intent(in), optional :: unit
end subroutine flavor_write
<<Flavors: procedures>>=
module subroutine flavor_write (flv, unit)
class(flavor_t), intent(in) :: flv
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
if (associated (flv%field_data)) then
write (u, "(A)", advance="no") "f("
else
write (u, "(A)", advance="no") "p("
end if
write (u, "(I0)", advance="no") flv%f
if (flv%radiated) then
write (u, "('*')", advance="no")
end if
if (msg_level (D_FLAVOR) >= DEBUG) then
if (flv%hard_process) then
write (u, "('#')", advance="no")
end if
end if
write (u, "(A)", advance="no") ")"
end subroutine flavor_write
@ %def flavor_write
@
<<Flavors: public>>=
public :: flavor_write_array
<<Flavors: sub interfaces>>=
module subroutine flavor_write_array (flv, unit)
type(flavor_t), intent(in), dimension(:) :: flv
integer, intent(in), optional :: unit
end subroutine flavor_write_array
<<Flavors: procedures>>=
module subroutine flavor_write_array (flv, unit)
type(flavor_t), intent(in), dimension(:) :: flv
integer, intent(in), optional :: unit
integer :: u, i_flv
u = given_output_unit (unit); if (u < 0) return
do i_flv = 1, size (flv)
call flv(i_flv)%write (u)
if (i_flv /= size (flv)) write (u,"(A)", advance = "no") " / "
end do
write (u,"(A)")
end subroutine flavor_write_array
@ %def flavor_write_array
@ Binary I/O. Currently, the model information is not written/read,
so after reading the particle-data pointer is empty.
<<Flavors: flavor: TBP>>=
procedure :: write_raw => flavor_write_raw
procedure :: read_raw => flavor_read_raw
<<Flavors: sub interfaces>>=
module subroutine flavor_write_raw (flv, u)
class(flavor_t), intent(in) :: flv
integer, intent(in) :: u
end subroutine flavor_write_raw
module subroutine flavor_read_raw (flv, u, iostat)
class(flavor_t), intent(out) :: flv
integer, intent(in) :: u
integer, intent(out), optional :: iostat
end subroutine flavor_read_raw
<<Flavors: procedures>>=
module subroutine flavor_write_raw (flv, u)
class(flavor_t), intent(in) :: flv
integer, intent(in) :: u
write (u) flv%f
write (u) flv%radiated
write (u) flv%hard_process
end subroutine flavor_write_raw
module subroutine flavor_read_raw (flv, u, iostat)
class(flavor_t), intent(out) :: flv
integer, intent(in) :: u
integer, intent(out), optional :: iostat
read (u, iostat=iostat) flv%f
if (present (iostat)) then
if (iostat /= 0) return
end if
read (u, iostat=iostat) flv%radiated
read (u, iostat=iostat) flv%hard_process
end subroutine flavor_read_raw
@ %def flavor_write_raw flavor_read_raw
@
\subsubsection{Assignment}
Default assignment of flavor objects is possible, but cannot be used
in pure procedures, because a pointer assignment is involved.
Assign the particle pointer separately. This cannot be elemental, so
we define a scalar and an array version explicitly. We refer to an
array of flavors, not an array of models.
<<Flavors: flavor: TBP>>=
procedure :: set_model => flavor_set_model_single
<<Flavors: sub interfaces>>=
impure elemental module subroutine flavor_set_model_single (flv, model)
class(flavor_t), intent(inout) :: flv
class(model_data_t), intent(in), target :: model
end subroutine flavor_set_model_single
<<Flavors: procedures>>=
impure elemental module subroutine flavor_set_model_single (flv, model)
class(flavor_t), intent(inout) :: flv
class(model_data_t), intent(in), target :: model
if (flv%f /= UNDEFINED) &
flv%field_data => model%get_field_ptr (flv%f)
end subroutine flavor_set_model_single
@ %def flavor_set_model
@
\subsubsection{Predicates}
Return the definition status. By definition, the flavor object is
defined if the flavor PDG code is nonzero.
<<Flavors: flavor: TBP>>=
procedure :: is_defined => flavor_is_defined
<<Flavors: sub interfaces>>=
elemental module function flavor_is_defined (flv) result (defined)
class(flavor_t), intent(in) :: flv
logical :: defined
end function flavor_is_defined
<<Flavors: procedures>>=
elemental module function flavor_is_defined (flv) result (defined)
class(flavor_t), intent(in) :: flv
logical :: defined
defined = flv%f /= UNDEFINED
end function flavor_is_defined
@ %def flavor_is_defined
@ Check for valid flavor (including undefined). This is distinct from
the [[is_defined]] status. Invalid flavor is actually a specific PDG
code.
<<Flavors: flavor: TBP>>=
procedure :: is_valid => flavor_is_valid
<<Flavors: sub interfaces>>=
elemental module function flavor_is_valid (flv) result (valid)
class(flavor_t), intent(in) :: flv
logical :: valid
end function flavor_is_valid
<<Flavors: procedures>>=
elemental module function flavor_is_valid (flv) result (valid)
class(flavor_t), intent(in) :: flv
logical :: valid
valid = flv%f /= INVALID
end function flavor_is_valid
@ %def flavor_is_valid
@ Return true if the particle-data pointer is associated. (Debugging aid)
<<Flavors: flavor: TBP>>=
procedure :: is_associated => flavor_is_associated
<<Flavors: sub interfaces>>=
elemental module function flavor_is_associated (flv) result (flag)
class(flavor_t), intent(in) :: flv
logical :: flag
end function flavor_is_associated
<<Flavors: procedures>>=
elemental module function flavor_is_associated (flv) result (flag)
class(flavor_t), intent(in) :: flv
logical :: flag
flag = associated (flv%field_data)
end function flavor_is_associated
@ %def flavor_is_associated
@ Check the [[radiated]] flag. A radiated particle has a definite PDG
flavor status, but it is actually a pseudoparticle (a beam remnant)
which may be subject to fragmentation.
<<Flavors: flavor: TBP>>=
procedure :: is_radiated => flavor_is_radiated
<<Flavors: sub interfaces>>=
elemental module function flavor_is_radiated (flv) result (flag)
class(flavor_t), intent(in) :: flv
logical :: flag
end function flavor_is_radiated
<<Flavors: procedures>>=
elemental module function flavor_is_radiated (flv) result (flag)
class(flavor_t), intent(in) :: flv
logical :: flag
flag = flv%radiated
end function flavor_is_radiated
@ %def flavor_is_radiated
@ Check the [[hard_process]] flag. A particle is tagged with this flag if
it participates in the hard interaction and is not a beam remnant.
<<Flavors: flavor: TBP>>=
procedure :: is_hard_process => flavor_is_hard_process
<<Flavors: sub interfaces>>=
elemental module function flavor_is_hard_process (flv) result (flag)
class(flavor_t), intent(in) :: flv
logical :: flag
end function flavor_is_hard_process
<<Flavors: procedures>>=
elemental module function flavor_is_hard_process (flv) result (flag)
class(flavor_t), intent(in) :: flv
logical :: flag
flag = flv%hard_process
end function flavor_is_hard_process
@ %def flavor_is_hard_process
@
\subsubsection{Accessing contents}
With the exception of the PDG code, all particle property enquiries are
delegated to the [[field_data]] pointer. If this is unassigned, some
access function will crash.
Return the flavor as an integer
<<Flavors: flavor: TBP>>=
procedure :: get_pdg => flavor_get_pdg
<<Flavors: sub interfaces>>=
elemental module function flavor_get_pdg (flv) result (f)
integer :: f
class(flavor_t), intent(in) :: flv
end function flavor_get_pdg
<<Flavors: procedures>>=
elemental module function flavor_get_pdg (flv) result (f)
integer :: f
class(flavor_t), intent(in) :: flv
f = flv%f
end function flavor_get_pdg
@ %def flavor_get_pdg
@ Return the flavor of the antiparticle
<<Flavors: flavor: TBP>>=
procedure :: get_pdg_anti => flavor_get_pdg_anti
<<Flavors: sub interfaces>>=
elemental module function flavor_get_pdg_anti (flv) result (f)
integer :: f
class(flavor_t), intent(in) :: flv
end function flavor_get_pdg_anti
<<Flavors: procedures>>=
elemental module function flavor_get_pdg_anti (flv) result (f)
integer :: f
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
if (flv%field_data%has_antiparticle ()) then
f = -flv%f
else
f = flv%f
end if
else
f = 0
end if
end function flavor_get_pdg_anti
@ %def flavor_get_pdg_anti
@
Absolute value:
<<Flavors: flavor: TBP>>=
procedure :: get_pdg_abs => flavor_get_pdg_abs
<<Flavors: sub interfaces>>=
elemental module function flavor_get_pdg_abs (flv) result (f)
integer :: f
class(flavor_t), intent(in) :: flv
end function flavor_get_pdg_abs
<<Flavors: procedures>>=
elemental module function flavor_get_pdg_abs (flv) result (f)
integer :: f
class(flavor_t), intent(in) :: flv
f = abs (flv%f)
end function flavor_get_pdg_abs
@ %def flavor_get_pdg_abs
@
Generic properties
<<Flavors: flavor: TBP>>=
procedure :: is_visible => flavor_is_visible
procedure :: is_parton => flavor_is_parton
procedure :: is_beam_remnant => flavor_is_beam_remnant
procedure :: is_gauge => flavor_is_gauge
procedure :: is_left_handed => flavor_is_left_handed
procedure :: is_right_handed => flavor_is_right_handed
procedure :: is_antiparticle => flavor_is_antiparticle
procedure :: has_antiparticle => flavor_has_antiparticle
procedure :: is_stable => flavor_is_stable
procedure :: get_decays => flavor_get_decays
procedure :: decays_isotropically => flavor_decays_isotropically
procedure :: decays_diagonal => flavor_decays_diagonal
procedure :: has_decay_helicity => flavor_has_decay_helicity
procedure :: get_decay_helicity => flavor_get_decay_helicity
procedure :: is_polarized => flavor_is_polarized
<<Flavors: sub interfaces>>=
elemental module function flavor_is_visible (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_is_visible
elemental module function flavor_is_parton (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_is_parton
elemental module function flavor_is_beam_remnant (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_is_beam_remnant
elemental module function flavor_is_gauge (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_is_gauge
elemental module function flavor_is_left_handed (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_is_left_handed
elemental module function flavor_is_right_handed (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_is_right_handed
elemental module function flavor_is_antiparticle (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_is_antiparticle
elemental module function flavor_has_antiparticle (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_has_antiparticle
elemental module function flavor_is_stable (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_is_stable
module subroutine flavor_get_decays (flv, decay)
class(flavor_t), intent(in) :: flv
type(string_t), dimension(:), intent(out), allocatable :: decay
logical :: anti
end subroutine flavor_get_decays
elemental module function flavor_decays_isotropically (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_decays_isotropically
elemental module function flavor_decays_diagonal (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_decays_diagonal
elemental module function flavor_has_decay_helicity (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_has_decay_helicity
elemental module function flavor_get_decay_helicity (flv) result (hel)
integer :: hel
class(flavor_t), intent(in) :: flv
end function flavor_get_decay_helicity
elemental module function flavor_is_polarized (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
end function flavor_is_polarized
<<Flavors: procedures>>=
elemental module function flavor_is_visible (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
flag = flv%field_data%is_visible ()
else
flag = .false.
end if
end function flavor_is_visible
elemental module function flavor_is_parton (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
flag = flv%field_data%is_parton ()
else
flag = .false.
end if
end function flavor_is_parton
elemental module function flavor_is_beam_remnant (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
select case (abs (flv%f))
case (HADRON_REMNANT, &
HADRON_REMNANT_SINGLET, HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET)
flag = .true.
case default
flag = .false.
end select
end function flavor_is_beam_remnant
elemental module function flavor_is_gauge (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
flag = flv%field_data%is_gauge ()
else
flag = .false.
end if
end function flavor_is_gauge
elemental module function flavor_is_left_handed (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
if (flv%f > 0) then
flag = flv%field_data%is_left_handed ()
else
flag = flv%field_data%is_right_handed ()
end if
else
flag = .false.
end if
end function flavor_is_left_handed
elemental module function flavor_is_right_handed (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
if (flv%f > 0) then
flag = flv%field_data%is_right_handed ()
else
flag = flv%field_data%is_left_handed ()
end if
else
flag = .false.
end if
end function flavor_is_right_handed
elemental module function flavor_is_antiparticle (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
flag = flv%f < 0
end function flavor_is_antiparticle
elemental module function flavor_has_antiparticle (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
flag = flv%field_data%has_antiparticle ()
else
flag = .false.
end if
end function flavor_has_antiparticle
elemental module function flavor_is_stable (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
flag = flv%field_data%is_stable (anti = flv%f < 0)
else
flag = .true.
end if
end function flavor_is_stable
module subroutine flavor_get_decays (flv, decay)
class(flavor_t), intent(in) :: flv
type(string_t), dimension(:), intent(out), allocatable :: decay
logical :: anti
anti = flv%f < 0
if (.not. flv%field_data%is_stable (anti)) then
call flv%field_data%get_decays (decay, anti)
end if
end subroutine flavor_get_decays
elemental module function flavor_decays_isotropically (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
flag = flv%field_data%decays_isotropically (anti = flv%f < 0)
else
flag = .true.
end if
end function flavor_decays_isotropically
elemental module function flavor_decays_diagonal (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
flag = flv%field_data%decays_diagonal (anti = flv%f < 0)
else
flag = .true.
end if
end function flavor_decays_diagonal
elemental module function flavor_has_decay_helicity (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
flag = flv%field_data%has_decay_helicity (anti = flv%f < 0)
else
flag = .false.
end if
end function flavor_has_decay_helicity
elemental module function flavor_get_decay_helicity (flv) result (hel)
integer :: hel
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
hel = flv%field_data%decay_helicity (anti = flv%f < 0)
else
hel = 0
end if
end function flavor_get_decay_helicity
elemental module function flavor_is_polarized (flv) result (flag)
logical :: flag
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
flag = flv%field_data%is_polarized (anti = flv%f < 0)
else
flag = .false.
end if
end function flavor_is_polarized
@ %def flavor_is_visible
@ %def flavor_is_parton
@ %def flavor_is_beam_remnant
@ %def flavor_is_gauge
@ %def flavor_is_left_handed
@ %def flavor_is_right_handed
@ %def flavor_is_antiparticle
@ %def flavor_has_antiparticle
@ %def flavor_is_stable
@ %def flavor_get_decays
@ %def flavor_decays_isotropically
@ %def flavor_decays_diagonal
@ %def flavor_has_decays_helicity
@ %def flavor_get_decay_helicity
@ %def flavor_is_polarized
@ Names:
<<Flavors: flavor: TBP>>=
procedure :: get_name => flavor_get_name
procedure :: get_tex_name => flavor_get_tex_name
<<Flavors: sub interfaces>>=
elemental module function flavor_get_name (flv) result (name)
type(string_t) :: name
class(flavor_t), intent(in) :: flv
end function flavor_get_name
elemental module function flavor_get_tex_name (flv) result (name)
type(string_t) :: name
class(flavor_t), intent(in) :: flv
end function flavor_get_tex_name
<<Flavors: procedures>>=
elemental module function flavor_get_name (flv) result (name)
type(string_t) :: name
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
name = flv%field_data%get_name (flv%f < 0)
else
name = "?"
end if
end function flavor_get_name
elemental module function flavor_get_tex_name (flv) result (name)
type(string_t) :: name
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
name = flv%field_data%get_tex_name (flv%f < 0)
else
name = "?"
end if
end function flavor_get_tex_name
@ %def flavor_get_name flavor_get_tex_name
<<Flavors: flavor: TBP>>=
procedure :: get_spin_type => flavor_get_spin_type
procedure :: get_multiplicity => flavor_get_multiplicity
procedure :: get_isospin_type => flavor_get_isospin_type
procedure :: get_charge_type => flavor_get_charge_type
procedure :: get_color_type => flavor_get_color_type
<<Flavors: sub interfaces>>=
elemental module function flavor_get_spin_type (flv) result (type)
integer :: type
class(flavor_t), intent(in) :: flv
end function flavor_get_spin_type
elemental module function flavor_get_multiplicity (flv) result (type)
integer :: type
class(flavor_t), intent(in) :: flv
end function flavor_get_multiplicity
elemental module function flavor_get_isospin_type (flv) result (type)
integer :: type
class(flavor_t), intent(in) :: flv
end function flavor_get_isospin_type
elemental module function flavor_get_charge_type (flv) result (type)
integer :: type
class(flavor_t), intent(in) :: flv
end function flavor_get_charge_type
elemental module function flavor_get_color_type (flv) result (type)
integer :: type
class(flavor_t), intent(in) :: flv
end function flavor_get_color_type
<<Flavors: procedures>>=
elemental module function flavor_get_spin_type (flv) result (type)
integer :: type
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
type = flv%field_data%get_spin_type ()
else
type = 1
end if
end function flavor_get_spin_type
elemental module function flavor_get_multiplicity (flv) result (type)
integer :: type
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
type = flv%field_data%get_multiplicity ()
else
type = 1
end if
end function flavor_get_multiplicity
elemental module function flavor_get_isospin_type (flv) result (type)
integer :: type
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
type = flv%field_data%get_isospin_type ()
else
type = 1
end if
end function flavor_get_isospin_type
elemental module function flavor_get_charge_type (flv) result (type)
integer :: type
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
type = flv%field_data%get_charge_type ()
else
type = 1
end if
end function flavor_get_charge_type
elemental module function flavor_get_color_type (flv) result (type)
integer :: type
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
if (flavor_is_antiparticle (flv)) then
type = - flv%field_data%get_color_type ()
else
type = flv%field_data%get_color_type ()
end if
select case (type)
case (-1,-8); type = abs (type)
end select
else
type = 1
end if
end function flavor_get_color_type
@ %def flavor_get_spin_type
@ %def flavor_get_multiplicity
@ %def flavor_get_isospin_type
@ %def flavor_get_charge_type
@ %def flavor_get_color_type
@ These functions return real values:
<<Flavors: flavor: TBP>>=
procedure :: get_charge => flavor_get_charge
procedure :: get_mass => flavor_get_mass
procedure :: get_width => flavor_get_width
procedure :: get_isospin => flavor_get_isospin
<<Flavors: sub interfaces>>=
elemental module function flavor_get_charge (flv) result (charge)
real(default) :: charge
class(flavor_t), intent(in) :: flv
end function flavor_get_charge
elemental module function flavor_get_mass (flv) result (mass)
real(default) :: mass
class(flavor_t), intent(in) :: flv
end function flavor_get_mass
elemental module function flavor_get_width (flv) result (width)
real(default) :: width
class(flavor_t), intent(in) :: flv
end function flavor_get_width
elemental module function flavor_get_isospin (flv) result (isospin)
real(default) :: isospin
class(flavor_t), intent(in) :: flv
end function flavor_get_isospin
<<Flavors: procedures>>=
elemental module function flavor_get_charge (flv) result (charge)
real(default) :: charge
class(flavor_t), intent(in) :: flv
integer :: charge_type
if (associated (flv%field_data)) then
charge_type = flv%get_charge_type ()
if (charge_type == 0 .or. charge_type == 1) then
charge = 0
else
if (flavor_is_antiparticle (flv)) then
charge = - flv%field_data%get_charge ()
else
charge = flv%field_data%get_charge ()
end if
end if
else
charge = 0
end if
end function flavor_get_charge
elemental module function flavor_get_mass (flv) result (mass)
real(default) :: mass
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
mass = flv%field_data%get_mass ()
else
mass = 0
end if
end function flavor_get_mass
elemental module function flavor_get_width (flv) result (width)
real(default) :: width
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
width = flv%field_data%get_width ()
else
width = 0
end if
end function flavor_get_width
elemental module function flavor_get_isospin (flv) result (isospin)
real(default) :: isospin
class(flavor_t), intent(in) :: flv
if (associated (flv%field_data)) then
if (flavor_is_antiparticle (flv)) then
isospin = - flv%field_data%get_isospin ()
else
isospin = flv%field_data%get_isospin ()
end if
else
isospin = 0
end if
end function flavor_get_isospin
@ %def flavor_get_charge flavor_get_mass flavor_get_width
@ %def flavor_get_isospin
@
\subsubsection{Comparisons}
If one of the flavors is undefined, the other defined, they match.
<<Flavors: flavor: TBP>>=
generic :: operator(.match.) => flavor_match
generic :: operator(==) => flavor_eq
generic :: operator(/=) => flavor_neq
procedure, private :: flavor_match
procedure, private :: flavor_eq
procedure, private :: flavor_neq
@ %def .match. == /=
<<Flavors: sub interfaces>>=
elemental module function flavor_match (flv1, flv2) result (eq)
logical :: eq
class(flavor_t), intent(in) :: flv1, flv2
end function flavor_match
elemental module function flavor_eq (flv1, flv2) result (eq)
logical :: eq
class(flavor_t), intent(in) :: flv1, flv2
end function flavor_eq
<<Flavors: procedures>>=
elemental module function flavor_match (flv1, flv2) result (eq)
logical :: eq
class(flavor_t), intent(in) :: flv1, flv2
if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then
eq = flv1%f == flv2%f
else
eq = .true.
end if
end function flavor_match
elemental module function flavor_eq (flv1, flv2) result (eq)
logical :: eq
class(flavor_t), intent(in) :: flv1, flv2
if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then
eq = flv1%f == flv2%f
else if (flv1%f == UNDEFINED .and. flv2%f == UNDEFINED) then
eq = .true.
else
eq = .false.
end if
end function flavor_eq
@ %def flavor_match flavor_eq
<<Flavors: sub interfaces>>=
elemental module function flavor_neq (flv1, flv2) result (neq)
logical :: neq
class(flavor_t), intent(in) :: flv1, flv2
end function flavor_neq
<<Flavors: procedures>>=
elemental module function flavor_neq (flv1, flv2) result (neq)
logical :: neq
class(flavor_t), intent(in) :: flv1, flv2
if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then
neq = flv1%f /= flv2%f
else if (flv1%f == UNDEFINED .and. flv2%f == UNDEFINED) then
neq = .false.
else
neq = .true.
end if
end function flavor_neq
@ %def flavor_neq
@
\subsubsection{Tools}
Merge two flavor indices. This works only if both are equal or either
one is undefined, because we have no off-diagonal flavor entries.
Otherwise, generate an invalid flavor.
We cannot use elemental procedures because of the pointer component.
<<Flavors: public>>=
public :: operator(.merge.)
<<Flavors: interfaces>>=
interface operator(.merge.)
module procedure merge_flavors0
module procedure merge_flavors1
end interface
@ %def .merge.
<<Flavors: sub interfaces>>=
module function merge_flavors0 (flv1, flv2) result (flv)
type(flavor_t) :: flv
type(flavor_t), intent(in) :: flv1, flv2
end function merge_flavors0
module function merge_flavors1 (flv1, flv2) result (flv)
type(flavor_t), dimension(:), intent(in) :: flv1, flv2
type(flavor_t), dimension(size(flv1)) :: flv
end function merge_flavors1
<<Flavors: procedures>>=
module function merge_flavors0 (flv1, flv2) result (flv)
type(flavor_t) :: flv
type(flavor_t), intent(in) :: flv1, flv2
if (flavor_is_defined (flv1) .and. flavor_is_defined (flv2)) then
if (flv1 == flv2) then
flv = flv1
else
flv%f = INVALID
end if
else if (flavor_is_defined (flv1)) then
flv = flv1
else if (flavor_is_defined (flv2)) then
flv = flv2
end if
end function merge_flavors0
module function merge_flavors1 (flv1, flv2) result (flv)
type(flavor_t), dimension(:), intent(in) :: flv1, flv2
type(flavor_t), dimension(size(flv1)) :: flv
integer :: i
do i = 1, size (flv1)
flv(i) = flv1(i) .merge. flv2(i)
end do
end function merge_flavors1
@ %def merge_flavors
@ Generate consecutive color indices for a given flavor. The indices
are counted starting with the stored value of c, so new indices are
created each time this (impure) function is called. The counter can
be reset by the optional argument [[c_seed]] if desired. The optional
flag [[reverse]] is used only for octets. If set, the color and
anticolor entries of the octet particle are exchanged.
<<Flavors: public>>=
public :: color_from_flavor
<<Flavors: interfaces>>=
interface color_from_flavor
module procedure color_from_flavor0
module procedure color_from_flavor1
end interface
<<Flavors: sub interfaces>>=
module function color_from_flavor0 (flv, c_seed, reverse) result (col)
type(color_t) :: col
type(flavor_t), intent(in) :: flv
integer, intent(in), optional :: c_seed
logical, intent(in), optional :: reverse
end function color_from_flavor0
module function color_from_flavor1 (flv, c_seed, reverse) result (col)
type(flavor_t), dimension(:), intent(in) :: flv
integer, intent(in), optional :: c_seed
logical, intent(in), optional :: reverse
type(color_t), dimension(size(flv)) :: col
end function color_from_flavor1
<<Flavors: procedures>>=
module function color_from_flavor0 (flv, c_seed, reverse) result (col)
type(color_t) :: col
type(flavor_t), intent(in) :: flv
integer, intent(in), optional :: c_seed
logical, intent(in), optional :: reverse
integer, save :: c = 1
logical :: rev
if (present (c_seed)) c = c_seed
rev = .false.; if (present (reverse)) rev = reverse
select case (flavor_get_color_type (flv))
case (1)
call col%init ()
case (3)
call col%init ([c]); c = c + 1
case (-3)
call col%init ([-c]); c = c + 1
case (8)
if (rev) then
call col%init ([c+1, -c]); c = c + 2
else
call col%init ([c, -(c+1)]); c = c + 2
end if
end select
end function color_from_flavor0
module function color_from_flavor1 (flv, c_seed, reverse) result (col)
type(flavor_t), dimension(:), intent(in) :: flv
integer, intent(in), optional :: c_seed
logical, intent(in), optional :: reverse
type(color_t), dimension(size(flv)) :: col
integer :: i
col(1) = color_from_flavor0 (flv(1), c_seed, reverse)
do i = 2, size (flv)
col(i) = color_from_flavor0 (flv(i), reverse=reverse)
end do
end function color_from_flavor1
@ %def color_from_flavor
@ This procedure returns the flavor object for the antiparticle. The
antiparticle code may either be the same code or its negative.
<<Flavors: flavor: TBP>>=
procedure :: anti => flavor_anti
<<Flavors: sub interfaces>>=
module function flavor_anti (flv) result (aflv)
type(flavor_t) :: aflv
class(flavor_t), intent(in) :: flv
end function flavor_anti
<<Flavors: procedures>>=
module function flavor_anti (flv) result (aflv)
type(flavor_t) :: aflv
class(flavor_t), intent(in) :: flv
if (flavor_has_antiparticle (flv)) then
aflv%f = - flv%f
else
aflv%f = flv%f
end if
aflv%field_data => flv%field_data
end function flavor_anti
@ %def flavor_anti
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Quantum numbers}
This module collects helicity, color, and flavor in a single type and
defines procedures
<<[[quantum_numbers.f90]]>>=
<<File header>>
module quantum_numbers
use model_data
use helicities
use colors
use flavors
<<Standard module head>>
<<Quantum numbers: public>>
<<Quantum numbers: types>>
<<Quantum numbers: interfaces>>
interface
<<Quantum numbers: sub interfaces>>
end interface
end module quantum_numbers
@ %def quantum_numbers
@
<<[[quantum_numbers_sub.f90]]>>=
<<File header>>
submodule (quantum_numbers) quantum_numbers_s
use io_units
implicit none
contains
<<Quantum numbers: procedures>>
end submodule quantum_numbers_s
@ %def quantum_numbers_s
@
\subsection{The quantum number type}
<<Quantum numbers: public>>=
public :: quantum_numbers_t
<<Quantum numbers: types>>=
type :: quantum_numbers_t
private
type(flavor_t) :: f
type(color_t) :: c
type(helicity_t) :: h
integer :: sub = 0
contains
<<Quantum numbers: quantum numbers: TBP>>
end type quantum_numbers_t
@ %def quantum_number_t
@ Define quantum numbers: Initializer form. All arguments may be
present or absent.
Some elemental initializers are impure because they set the [[flv]]
component. This implies transfer of a pointer behind the scenes.
<<Quantum numbers: quantum numbers: TBP>>=
generic :: init => &
quantum_numbers_init_f, &
quantum_numbers_init_c, &
quantum_numbers_init_h, &
quantum_numbers_init_fc, &
quantum_numbers_init_fh, &
quantum_numbers_init_ch, &
quantum_numbers_init_fch, &
quantum_numbers_init_fs, &
quantum_numbers_init_fhs, &
quantum_numbers_init_fcs, &
quantum_numbers_init_fhcs
procedure, private :: quantum_numbers_init_f
procedure, private :: quantum_numbers_init_c
procedure, private :: quantum_numbers_init_h
procedure, private :: quantum_numbers_init_fc
procedure, private :: quantum_numbers_init_fh
procedure, private :: quantum_numbers_init_ch
procedure, private :: quantum_numbers_init_fch
procedure, private :: quantum_numbers_init_fs
procedure, private :: quantum_numbers_init_fhs
procedure, private :: quantum_numbers_init_fcs
procedure, private :: quantum_numbers_init_fhcs
<<Quantum numbers: sub interfaces>>=
impure elemental module subroutine quantum_numbers_init_f (qn, flv)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
end subroutine quantum_numbers_init_f
impure elemental module subroutine quantum_numbers_init_c (qn, col)
class(quantum_numbers_t), intent(out) :: qn
type(color_t), intent(in) :: col
end subroutine quantum_numbers_init_c
impure elemental module subroutine quantum_numbers_init_h (qn, hel)
class(quantum_numbers_t), intent(out) :: qn
type(helicity_t), intent(in) :: hel
end subroutine quantum_numbers_init_h
impure elemental module subroutine quantum_numbers_init_fc (qn, flv, col)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
type(color_t), intent(in) :: col
end subroutine quantum_numbers_init_fc
impure elemental module subroutine quantum_numbers_init_fh (qn, flv, hel)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
type(helicity_t), intent(in) :: hel
end subroutine quantum_numbers_init_fh
impure elemental module subroutine quantum_numbers_init_ch (qn, col, hel)
class(quantum_numbers_t), intent(out) :: qn
type(color_t), intent(in) :: col
type(helicity_t), intent(in) :: hel
end subroutine quantum_numbers_init_ch
impure elemental module subroutine quantum_numbers_init_fch (qn, flv, col, hel)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
type(color_t), intent(in) :: col
type(helicity_t), intent(in) :: hel
end subroutine quantum_numbers_init_fch
impure elemental module subroutine quantum_numbers_init_fs (qn, flv, sub)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
integer, intent(in) :: sub
end subroutine quantum_numbers_init_fs
impure elemental module subroutine quantum_numbers_init_fhs (qn, flv, hel, sub)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
type(helicity_t), intent(in) :: hel
integer, intent(in) :: sub
end subroutine quantum_numbers_init_fhs
impure elemental module subroutine quantum_numbers_init_fcs (qn, flv, col, sub)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
type(color_t), intent(in) :: col
integer, intent(in) :: sub
end subroutine quantum_numbers_init_fcs
impure elemental module subroutine quantum_numbers_init_fhcs (qn, flv, hel, col, sub)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
type(helicity_t), intent(in) :: hel
type(color_t), intent(in) :: col
integer, intent(in) :: sub
end subroutine quantum_numbers_init_fhcs
<<Quantum numbers: procedures>>=
impure elemental module subroutine quantum_numbers_init_f (qn, flv)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
qn%f = flv
call qn%c%undefine ()
call qn%h%undefine ()
qn%sub = 0
end subroutine quantum_numbers_init_f
impure elemental module subroutine quantum_numbers_init_c (qn, col)
class(quantum_numbers_t), intent(out) :: qn
type(color_t), intent(in) :: col
call qn%f%undefine ()
qn%c = col
call qn%h%undefine ()
qn%sub = 0
end subroutine quantum_numbers_init_c
impure elemental module subroutine quantum_numbers_init_h (qn, hel)
class(quantum_numbers_t), intent(out) :: qn
type(helicity_t), intent(in) :: hel
call qn%f%undefine ()
call qn%c%undefine ()
qn%h = hel
qn%sub = 0
end subroutine quantum_numbers_init_h
impure elemental module subroutine quantum_numbers_init_fc (qn, flv, col)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
type(color_t), intent(in) :: col
qn%f = flv
qn%c = col
call qn%h%undefine ()
qn%sub = 0
end subroutine quantum_numbers_init_fc
impure elemental module subroutine quantum_numbers_init_fh (qn, flv, hel)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
type(helicity_t), intent(in) :: hel
qn%f = flv
call qn%c%undefine ()
qn%h = hel
qn%sub = 0
end subroutine quantum_numbers_init_fh
impure elemental module subroutine quantum_numbers_init_ch (qn, col, hel)
class(quantum_numbers_t), intent(out) :: qn
type(color_t), intent(in) :: col
type(helicity_t), intent(in) :: hel
call qn%f%undefine ()
qn%c = col
qn%h = hel
qn%sub = 0
end subroutine quantum_numbers_init_ch
impure elemental module subroutine quantum_numbers_init_fch (qn, flv, col, hel)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
type(color_t), intent(in) :: col
type(helicity_t), intent(in) :: hel
qn%f = flv
qn%c = col
qn%h = hel
qn%sub = 0
end subroutine quantum_numbers_init_fch
impure elemental module subroutine quantum_numbers_init_fs (qn, flv, sub)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
integer, intent(in) :: sub
qn%f = flv; qn%sub = sub
end subroutine quantum_numbers_init_fs
impure elemental module subroutine quantum_numbers_init_fhs (qn, flv, hel, sub)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
type(helicity_t), intent(in) :: hel
integer, intent(in) :: sub
qn%f = flv; qn%h = hel; qn%sub = sub
end subroutine quantum_numbers_init_fhs
impure elemental module subroutine quantum_numbers_init_fcs (qn, flv, col, sub)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
type(color_t), intent(in) :: col
integer, intent(in) :: sub
qn%f = flv; qn%c = col; qn%sub = sub
end subroutine quantum_numbers_init_fcs
impure elemental module subroutine quantum_numbers_init_fhcs (qn, flv, hel, col, sub)
class(quantum_numbers_t), intent(out) :: qn
type(flavor_t), intent(in) :: flv
type(helicity_t), intent(in) :: hel
type(color_t), intent(in) :: col
integer, intent(in) :: sub
qn%f = flv; qn%h = hel; qn%c = col; qn%sub = sub
end subroutine quantum_numbers_init_fhcs
@ %def quantum_numbers_init
@
\subsection{I/O}
Write the quantum numbers in condensed form, enclosed by square
brackets. Color is written only if nontrivial. For convenience,
introduce also an array version.
If the [[col_verbose]] option is set, show the quantum number color also
if it is zero, but defined. Otherwise, suppress zero color.
<<Quantum numbers: public>>=
public :: quantum_numbers_write
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: write => quantum_numbers_write_single
<<Quantum numbers: interfaces>>=
interface quantum_numbers_write
module procedure quantum_numbers_write_single
module procedure quantum_numbers_write_array
end interface
<<Quantum numbers: sub interfaces>>=
module subroutine quantum_numbers_write_single (qn, unit, col_verbose)
class(quantum_numbers_t), intent(in) :: qn
integer, intent(in), optional :: unit
logical, intent(in), optional :: col_verbose
end subroutine quantum_numbers_write_single
module subroutine quantum_numbers_write_array (qn, unit, col_verbose)
type(quantum_numbers_t), dimension(:), intent(in) :: qn
integer, intent(in), optional :: unit
logical, intent(in), optional :: col_verbose
end subroutine quantum_numbers_write_array
<<Quantum numbers: procedures>>=
module subroutine quantum_numbers_write_single (qn, unit, col_verbose)
class(quantum_numbers_t), intent(in) :: qn
integer, intent(in), optional :: unit
logical, intent(in), optional :: col_verbose
integer :: u
logical :: col_verb
u = given_output_unit (unit); if (u < 0) return
col_verb = .false.; if (present (col_verbose)) col_verb = col_verbose
write (u, "(A)", advance = "no") "["
if (qn%f%is_defined ()) then
call qn%f%write (u)
if (qn%c%is_nonzero () .or. qn%h%is_defined ()) &
write (u, "(1x)", advance = "no")
end if
if (col_verb) then
if (qn%c%is_defined () .or. qn%c%is_ghost ()) then
call color_write (qn%c, u)
if (qn%h%is_defined ()) write (u, "(1x)", advance = "no")
end if
else
if (qn%c%is_nonzero () .or. qn%c%is_ghost ()) then
call color_write (qn%c, u)
if (qn%h%is_defined ()) write (u, "(1x)", advance = "no")
end if
end if
if (qn%h%is_defined ()) then
call qn%h%write (u)
end if
if (qn%sub > 0) &
write (u, "(A,I0)", advance = "no") " SUB = ", qn%sub
write (u, "(A)", advance="no") "]"
end subroutine quantum_numbers_write_single
module subroutine quantum_numbers_write_array (qn, unit, col_verbose)
type(quantum_numbers_t), dimension(:), intent(in) :: qn
integer, intent(in), optional :: unit
logical, intent(in), optional :: col_verbose
integer :: i
integer :: u
logical :: col_verb
u = given_output_unit (unit); if (u < 0) return
col_verb = .false.; if (present (col_verbose)) col_verb = col_verbose
write (u, "(A)", advance="no") "["
do i = 1, size (qn)
if (i > 1) write (u, "(A)", advance="no") " / "
if (qn(i)%f%is_defined ()) then
call qn(i)%f%write (u)
if (qn(i)%c%is_nonzero () .or. qn(i)%h%is_defined ()) &
write (u, "(1x)", advance="no")
end if
if (col_verb) then
if (qn(i)%c%is_defined () .or. qn(i)%c%is_ghost ()) then
call color_write (qn(i)%c, u)
if (qn(i)%h%is_defined ()) write (u, "(1x)", advance="no")
end if
else
if (qn(i)%c%is_nonzero () .or. qn(i)%c%is_ghost ()) then
call color_write (qn(i)%c, u)
if (qn(i)%h%is_defined ()) write (u, "(1x)", advance="no")
end if
end if
if (qn(i)%h%is_defined ()) then
call qn(i)%h%write (u)
end if
if (qn(i)%sub > 0) &
write (u, "(A,I2)", advance = "no") " SUB = ", qn(i)%sub
end do
write (u, "(A)", advance = "no") "]"
end subroutine quantum_numbers_write_array
@ %def quantum_numbers_write
@ Binary I/O.
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: write_raw => quantum_numbers_write_raw
procedure :: read_raw => quantum_numbers_read_raw
<<Quantum numbers: sub interfaces>>=
module subroutine quantum_numbers_write_raw (qn, u)
class(quantum_numbers_t), intent(in) :: qn
integer, intent(in) :: u
end subroutine quantum_numbers_write_raw
module subroutine quantum_numbers_read_raw (qn, u, iostat)
class(quantum_numbers_t), intent(out) :: qn
integer, intent(in) :: u
integer, intent(out), optional :: iostat
end subroutine quantum_numbers_read_raw
<<Quantum numbers: procedures>>=
module subroutine quantum_numbers_write_raw (qn, u)
class(quantum_numbers_t), intent(in) :: qn
integer, intent(in) :: u
call qn%f%write_raw (u)
call qn%c%write_raw (u)
call qn%h%write_raw (u)
end subroutine quantum_numbers_write_raw
module subroutine quantum_numbers_read_raw (qn, u, iostat)
class(quantum_numbers_t), intent(out) :: qn
integer, intent(in) :: u
integer, intent(out), optional :: iostat
call qn%f%read_raw (u, iostat=iostat)
call qn%c%read_raw (u, iostat=iostat)
call qn%h%read_raw (u, iostat=iostat)
end subroutine quantum_numbers_read_raw
@ %def quantum_numbers_write_raw quantum_numbers_read_raw
@
\subsection{Accessing contents}
Color and helicity can be done by elemental functions. Flavor needs
impure elemental. We export also the functions directly, this allows
us to avoid temporaries in some places.
<<Quantum numbers: public>>=
public :: quantum_numbers_get_flavor
public :: quantum_numbers_get_color
public :: quantum_numbers_get_helicity
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: get_flavor => quantum_numbers_get_flavor
procedure :: get_color => quantum_numbers_get_color
procedure :: get_helicity => quantum_numbers_get_helicity
procedure :: get_sub => quantum_numbers_get_sub
<<Quantum numbers: sub interfaces>>=
impure elemental module function quantum_numbers_get_flavor (qn) result (flv)
type(flavor_t) :: flv
class(quantum_numbers_t), intent(in) :: qn
end function quantum_numbers_get_flavor
elemental module function quantum_numbers_get_color (qn) result (col)
type(color_t) :: col
class(quantum_numbers_t), intent(in) :: qn
end function quantum_numbers_get_color
elemental module function quantum_numbers_get_helicity (qn) result (hel)
type(helicity_t) :: hel
class(quantum_numbers_t), intent(in) :: qn
end function quantum_numbers_get_helicity
elemental module function quantum_numbers_get_sub (qn) result (sub)
integer :: sub
class(quantum_numbers_t), intent(in) :: qn
end function quantum_numbers_get_sub
<<Quantum numbers: procedures>>=
impure elemental module function quantum_numbers_get_flavor (qn) result (flv)
type(flavor_t) :: flv
class(quantum_numbers_t), intent(in) :: qn
flv = qn%f
end function quantum_numbers_get_flavor
elemental module function quantum_numbers_get_color (qn) result (col)
type(color_t) :: col
class(quantum_numbers_t), intent(in) :: qn
col = qn%c
end function quantum_numbers_get_color
elemental module function quantum_numbers_get_helicity (qn) result (hel)
type(helicity_t) :: hel
class(quantum_numbers_t), intent(in) :: qn
hel = qn%h
end function quantum_numbers_get_helicity
elemental module function quantum_numbers_get_sub (qn) result (sub)
integer :: sub
class(quantum_numbers_t), intent(in) :: qn
sub = qn%sub
end function quantum_numbers_get_sub
@ %def quantum_numbers_get_flavor
@ %def quantum_numbers_get_color
@ %def quantum_numbers_get_helicity
@ %def quantum_numbers_get_sub
@ This just resets the ghost property of the color part:
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: set_color_ghost => quantum_numbers_set_color_ghost
<<Quantum numbers: sub interfaces>>=
elemental module subroutine quantum_numbers_set_color_ghost (qn, ghost)
class(quantum_numbers_t), intent(inout) :: qn
logical, intent(in) :: ghost
end subroutine quantum_numbers_set_color_ghost
<<Quantum numbers: procedures>>=
elemental module subroutine quantum_numbers_set_color_ghost (qn, ghost)
class(quantum_numbers_t), intent(inout) :: qn
logical, intent(in) :: ghost
call qn%c%set_ghost (ghost)
end subroutine quantum_numbers_set_color_ghost
@ %def quantum_numbers_set_color_ghost
@ Assign a model to the flavor part of quantum numbers.
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: set_model => quantum_numbers_set_model
<<Quantum numbers: sub interfaces>>=
impure elemental module subroutine quantum_numbers_set_model (qn, model)
class(quantum_numbers_t), intent(inout) :: qn
class(model_data_t), intent(in), target :: model
end subroutine quantum_numbers_set_model
<<Quantum numbers: procedures>>=
impure elemental module subroutine quantum_numbers_set_model (qn, model)
class(quantum_numbers_t), intent(inout) :: qn
class(model_data_t), intent(in), target :: model
call qn%f%set_model (model)
end subroutine quantum_numbers_set_model
@ %def quantum_numbers_set_model
@ Set the [[radiated]] flag for the flavor component.
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: tag_radiated => quantum_numbers_tag_radiated
<<Quantum numbers: sub interfaces>>=
elemental module subroutine quantum_numbers_tag_radiated (qn)
class(quantum_numbers_t), intent(inout) :: qn
end subroutine quantum_numbers_tag_radiated
<<Quantum numbers: procedures>>=
elemental module subroutine quantum_numbers_tag_radiated (qn)
class(quantum_numbers_t), intent(inout) :: qn
call qn%f%tag_radiated ()
end subroutine quantum_numbers_tag_radiated
@ %def quantum_numbers_tag_radiated
@ Set the [[hard_process]] flag for the flavor component.
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: tag_hard_process => quantum_numbers_tag_hard_process
<<Quantum numbers: sub interfaces>>=
elemental module subroutine quantum_numbers_tag_hard_process (qn, hard)
class(quantum_numbers_t), intent(inout) :: qn
logical, intent(in), optional :: hard
end subroutine quantum_numbers_tag_hard_process
<<Quantum numbers: procedures>>=
elemental module subroutine quantum_numbers_tag_hard_process (qn, hard)
class(quantum_numbers_t), intent(inout) :: qn
logical, intent(in), optional :: hard
call qn%f%tag_hard_process (hard)
end subroutine quantum_numbers_tag_hard_process
@ %def quantum_numbers_tag_hard_process
@
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: set_subtraction_index => &
quantum_numbers_set_subtraction_index
<<Quantum numbers: sub interfaces>>=
elemental module subroutine quantum_numbers_set_subtraction_index (qn, i)
class(quantum_numbers_t), intent(inout) :: qn
integer, intent(in) :: i
end subroutine quantum_numbers_set_subtraction_index
<<Quantum numbers: procedures>>=
elemental module subroutine quantum_numbers_set_subtraction_index (qn, i)
class(quantum_numbers_t), intent(inout) :: qn
integer, intent(in) :: i
qn%sub = i
end subroutine quantum_numbers_set_subtraction_index
@ %def quantum_numbers_set_subtraction_index
@
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: get_subtraction_index => &
quantum_numbers_get_subtraction_index
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_get_subtraction_index &
(qn) result (sub)
integer :: sub
class(quantum_numbers_t), intent(in) :: qn
end function quantum_numbers_get_subtraction_index
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_get_subtraction_index &
(qn) result (sub)
integer :: sub
class(quantum_numbers_t), intent(in) :: qn
sub = qn%sub
end function quantum_numbers_get_subtraction_index
@ %def quantum_numbers_get_subtraction_index
@ This is a convenience function: return the color type for the flavor
(array).
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: get_color_type => quantum_numbers_get_color_type
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_get_color_type (qn) result (color_type)
integer :: color_type
class(quantum_numbers_t), intent(in) :: qn
end function quantum_numbers_get_color_type
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_get_color_type (qn) result (color_type)
integer :: color_type
class(quantum_numbers_t), intent(in) :: qn
color_type = qn%f%get_color_type ()
end function quantum_numbers_get_color_type
@ %def quantum_numbers_get_color_type
@
\subsection{Predicates}
Check if the flavor index is valid (including UNDEFINED).
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: are_valid => quantum_numbers_are_valid
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_are_valid (qn) result (valid)
logical :: valid
class(quantum_numbers_t), intent(in) :: qn
end function quantum_numbers_are_valid
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_are_valid (qn) result (valid)
logical :: valid
class(quantum_numbers_t), intent(in) :: qn
valid = qn%f%is_valid ()
end function quantum_numbers_are_valid
@ %def quantum_numbers_are_valid
@ Check if the flavor part has its particle-data pointer associated
(debugging aid).
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: are_associated => quantum_numbers_are_associated
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_are_associated (qn) result (flag)
logical :: flag
class(quantum_numbers_t), intent(in) :: qn
end function quantum_numbers_are_associated
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_are_associated (qn) result (flag)
logical :: flag
class(quantum_numbers_t), intent(in) :: qn
flag = qn%f%is_associated ()
end function quantum_numbers_are_associated
@ %def quantum_numbers_are_associated
@ Check if the helicity and color quantum numbers are
diagonal. (Unpolarized/colorless also counts as diagonal.) Flavor is
diagonal by definition.
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: are_diagonal => quantum_numbers_are_diagonal
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_are_diagonal (qn) result (diagonal)
logical :: diagonal
class(quantum_numbers_t), intent(in) :: qn
end function quantum_numbers_are_diagonal
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_are_diagonal (qn) result (diagonal)
logical :: diagonal
class(quantum_numbers_t), intent(in) :: qn
diagonal = qn%h%is_diagonal () .and. qn%c%is_diagonal ()
end function quantum_numbers_are_diagonal
@ %def quantum_numbers_are_diagonal
@ Check if the color part has the ghost property.
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: is_color_ghost => quantum_numbers_is_color_ghost
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_is_color_ghost (qn) result (ghost)
logical :: ghost
class(quantum_numbers_t), intent(in) :: qn
end function quantum_numbers_is_color_ghost
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_is_color_ghost (qn) result (ghost)
logical :: ghost
class(quantum_numbers_t), intent(in) :: qn
ghost = qn%c%is_ghost ()
end function quantum_numbers_is_color_ghost
@ %def quantum_numbers_is_color_ghost
@ Check if the flavor participates in the hard interaction.
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: are_hard_process => quantum_numbers_are_hard_process
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_are_hard_process &
(qn) result (hard_process)
logical :: hard_process
class(quantum_numbers_t), intent(in) :: qn
end function quantum_numbers_are_hard_process
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_are_hard_process &
(qn) result (hard_process)
logical :: hard_process
class(quantum_numbers_t), intent(in) :: qn
hard_process = qn%f%is_hard_process ()
end function quantum_numbers_are_hard_process
@ %def quantum_numbers_are_hard_process
@
\subsection{Comparisons}
Matching and equality is derived from the individual quantum numbers.
The variant [[fhmatch]] matches only flavor and helicity. The variant
[[dhmatch]] matches only diagonal helicity, if the matching helicity is
undefined.
<<Quantum numbers: public>>=
public :: quantum_numbers_eq_wo_sub
<<Quantum numbers: quantum numbers: TBP>>=
generic :: operator(.match.) => quantum_numbers_match
generic :: operator(.fmatch.) => quantum_numbers_match_f
generic :: operator(.hmatch.) => quantum_numbers_match_h
generic :: operator(.fhmatch.) => quantum_numbers_match_fh
generic :: operator(.dhmatch.) => quantum_numbers_match_hel_diag
generic :: operator(==) => quantum_numbers_eq
generic :: operator(/=) => quantum_numbers_neq
procedure, private :: quantum_numbers_match
procedure, private :: quantum_numbers_match_f
procedure, private :: quantum_numbers_match_h
procedure, private :: quantum_numbers_match_fh
procedure, private :: quantum_numbers_match_hel_diag
procedure, private :: quantum_numbers_eq
procedure, private :: quantum_numbers_neq
@ %def .match. == /=
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_match (qn1, qn2) result (match)
logical :: match
class(quantum_numbers_t), intent(in) :: qn1, qn2
end function quantum_numbers_match
elemental module function quantum_numbers_match_f (qn1, qn2) result (match)
logical :: match
class(quantum_numbers_t), intent(in) :: qn1, qn2
end function quantum_numbers_match_f
elemental module function quantum_numbers_match_h (qn1, qn2) result (match)
logical :: match
class(quantum_numbers_t), intent(in) :: qn1, qn2
end function quantum_numbers_match_h
elemental module function quantum_numbers_match_fh (qn1, qn2) result (match)
logical :: match
class(quantum_numbers_t), intent(in) :: qn1, qn2
end function quantum_numbers_match_fh
elemental module function quantum_numbers_match_hel_diag (qn1, qn2) result (match)
logical :: match
class(quantum_numbers_t), intent(in) :: qn1, qn2
end function quantum_numbers_match_hel_diag
elemental module function quantum_numbers_eq_wo_sub (qn1, qn2) result (eq)
logical :: eq
type(quantum_numbers_t), intent(in) :: qn1, qn2
end function quantum_numbers_eq_wo_sub
elemental module function quantum_numbers_eq (qn1, qn2) result (eq)
logical :: eq
class(quantum_numbers_t), intent(in) :: qn1, qn2
end function quantum_numbers_eq
elemental module function quantum_numbers_neq (qn1, qn2) result (neq)
logical :: neq
class(quantum_numbers_t), intent(in) :: qn1, qn2
end function quantum_numbers_neq
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_match (qn1, qn2) result (match)
logical :: match
class(quantum_numbers_t), intent(in) :: qn1, qn2
match = (qn1%f .match. qn2%f) .and. &
(qn1%c .match. qn2%c) .and. &
(qn1%h .match. qn2%h)
end function quantum_numbers_match
elemental module function quantum_numbers_match_f (qn1, qn2) result (match)
logical :: match
class(quantum_numbers_t), intent(in) :: qn1, qn2
match = (qn1%f .match. qn2%f)
end function quantum_numbers_match_f
elemental module function quantum_numbers_match_h (qn1, qn2) result (match)
logical :: match
class(quantum_numbers_t), intent(in) :: qn1, qn2
match = (qn1%h .match. qn2%h)
end function quantum_numbers_match_h
elemental module function quantum_numbers_match_fh (qn1, qn2) result (match)
logical :: match
class(quantum_numbers_t), intent(in) :: qn1, qn2
match = (qn1%f .match. qn2%f) .and. &
(qn1%h .match. qn2%h)
end function quantum_numbers_match_fh
elemental module function quantum_numbers_match_hel_diag (qn1, qn2) result (match)
logical :: match
class(quantum_numbers_t), intent(in) :: qn1, qn2
match = (qn1%f .match. qn2%f) .and. &
(qn1%c .match. qn2%c) .and. &
(qn1%h .dmatch. qn2%h)
end function quantum_numbers_match_hel_diag
elemental module function quantum_numbers_eq_wo_sub (qn1, qn2) result (eq)
logical :: eq
type(quantum_numbers_t), intent(in) :: qn1, qn2
eq = (qn1%f == qn2%f) .and. &
(qn1%c == qn2%c) .and. &
(qn1%h == qn2%h)
end function quantum_numbers_eq_wo_sub
elemental module function quantum_numbers_eq (qn1, qn2) result (eq)
logical :: eq
class(quantum_numbers_t), intent(in) :: qn1, qn2
eq = (qn1%f == qn2%f) .and. &
(qn1%c == qn2%c) .and. &
(qn1%h == qn2%h) .and. &
(qn1%sub == qn2%sub)
end function quantum_numbers_eq
elemental module function quantum_numbers_neq (qn1, qn2) result (neq)
logical :: neq
class(quantum_numbers_t), intent(in) :: qn1, qn2
neq = (qn1%f /= qn2%f) .or. &
(qn1%c /= qn2%c) .or. &
(qn1%h /= qn2%h) .or. &
(qn1%sub /= qn2%sub)
end function quantum_numbers_neq
@ %def quantum_numbers_match
@ %def quantum_numbers_eq
@ %def quantum_numbers_neq
<<Quantum numbers: public>>=
public :: assignment(=)
<<Quantum numbers: interfaces>>=
interface assignment(=)
module procedure quantum_numbers_assign
end interface
<<Quantum numbers: sub interfaces>>=
module subroutine quantum_numbers_assign (qn_out, qn_in)
type(quantum_numbers_t), intent(out) :: qn_out
type(quantum_numbers_t), intent(in) :: qn_in
end subroutine quantum_numbers_assign
<<Quantum numbers: procedures>>=
module subroutine quantum_numbers_assign (qn_out, qn_in)
type(quantum_numbers_t), intent(out) :: qn_out
type(quantum_numbers_t), intent(in) :: qn_in
qn_out%f = qn_in%f
qn_out%c = qn_in%c
qn_out%h = qn_in%h
qn_out%sub = qn_in%sub
end subroutine quantum_numbers_assign
@ %def quantum_numbers_assign
@ Two sets of quantum numbers are compatible if the individual quantum numbers
are compatible, depending on the mask. Flavor has to match, regardless of the
flavor mask.
If the color flag is set, color is compatible if the ghost property is
identical. If the color flag is unset, color has to be identical. I.e., if
the flag is set, the color amplitudes can interfere. If it is not set, they
must be identical, and there must be no ghost. The latter property is used
for expanding physical color flows.
Helicity is compatible if the mask is unset, otherwise it has to match. This
determines if two amplitudes can be multiplied (no mask) or traced (mask).
<<Quantum numbers: public>>=
public :: quantum_numbers_are_compatible
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_are_compatible &
(qn1, qn2, mask) result (flag)
logical :: flag
type(quantum_numbers_t), intent(in) :: qn1, qn2
type(quantum_numbers_mask_t), intent(in) :: mask
end function quantum_numbers_are_compatible
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_are_compatible &
(qn1, qn2, mask) result (flag)
logical :: flag
type(quantum_numbers_t), intent(in) :: qn1, qn2
type(quantum_numbers_mask_t), intent(in) :: mask
if (mask%h .or. mask%hd) then
flag = (qn1%f .match. qn2%f) .and. (qn1%h .match. qn2%h)
else
flag = (qn1%f .match. qn2%f)
end if
if (mask%c) then
flag = flag .and. (qn1%c%is_ghost () .eqv. qn2%c%is_ghost ())
else
flag = flag .and. &
.not. (qn1%c%is_ghost () .or. qn2%c%is_ghost ()) .and. &
(qn1%c == qn2%c)
end if
end function quantum_numbers_are_compatible
@ %def quantum_numbers_are_compatible
@ This is the analog for a single quantum-number set. We just check for color
ghosts; they are excluded if the color mask is unset (color-flow expansion).
<<Quantum numbers: public>>=
public :: quantum_numbers_are_physical
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_are_physical (qn, mask) result (flag)
logical :: flag
type(quantum_numbers_t), intent(in) :: qn
type(quantum_numbers_mask_t), intent(in) :: mask
end function quantum_numbers_are_physical
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_are_physical (qn, mask) result (flag)
logical :: flag
type(quantum_numbers_t), intent(in) :: qn
type(quantum_numbers_mask_t), intent(in) :: mask
if (mask%c) then
flag = .true.
else
flag = .not. qn%c%is_ghost ()
end if
end function quantum_numbers_are_physical
@ %def quantum_numbers_are_physical
@
\subsection{Operations}
Inherited from the color component: reassign color indices in
canonical order.
<<Quantum numbers: public>>=
public :: quantum_numbers_canonicalize_color
<<Quantum numbers: sub interfaces>>=
module subroutine quantum_numbers_canonicalize_color (qn)
type(quantum_numbers_t), dimension(:), intent(inout) :: qn
end subroutine quantum_numbers_canonicalize_color
<<Quantum numbers: procedures>>=
module subroutine quantum_numbers_canonicalize_color (qn)
type(quantum_numbers_t), dimension(:), intent(inout) :: qn
call color_canonicalize (qn%c)
end subroutine quantum_numbers_canonicalize_color
@ %def quantum_numbers_canonicalize_color
@ Inherited from the color component: make a color map for two matching
quantum-number arrays.
<<Quantum numbers: public>>=
public :: make_color_map
<<Quantum numbers: interfaces>>=
interface make_color_map
module procedure quantum_numbers_make_color_map
end interface make_color_map
<<Quantum numbers: sub interfaces>>=
module subroutine quantum_numbers_make_color_map (map, qn1, qn2)
integer, dimension(:,:), intent(out), allocatable :: map
type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2
end subroutine quantum_numbers_make_color_map
<<Quantum numbers: procedures>>=
module subroutine quantum_numbers_make_color_map (map, qn1, qn2)
integer, dimension(:,:), intent(out), allocatable :: map
type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2
call make_color_map (map, qn1%c, qn2%c)
end subroutine quantum_numbers_make_color_map
@ %def make_color_map
@ Inherited from the color component: translate the color part using a
color-map array
<<Quantum numbers: public>>=
public :: quantum_numbers_translate_color
<<Quantum numbers: interfaces>>=
interface quantum_numbers_translate_color
module procedure quantum_numbers_translate_color0
module procedure quantum_numbers_translate_color1
end interface
<<Quantum numbers: sub interfaces>>=
module subroutine quantum_numbers_translate_color0 (qn, map, offset)
type(quantum_numbers_t), intent(inout) :: qn
integer, dimension(:,:), intent(in) :: map
integer, intent(in), optional :: offset
end subroutine quantum_numbers_translate_color0
module subroutine quantum_numbers_translate_color1 (qn, map, offset)
type(quantum_numbers_t), dimension(:), intent(inout) :: qn
integer, dimension(:,:), intent(in) :: map
integer, intent(in), optional :: offset
end subroutine quantum_numbers_translate_color1
<<Quantum numbers: procedures>>=
module subroutine quantum_numbers_translate_color0 (qn, map, offset)
type(quantum_numbers_t), intent(inout) :: qn
integer, dimension(:,:), intent(in) :: map
integer, intent(in), optional :: offset
call color_translate (qn%c, map, offset)
end subroutine quantum_numbers_translate_color0
module subroutine quantum_numbers_translate_color1 (qn, map, offset)
type(quantum_numbers_t), dimension(:), intent(inout) :: qn
integer, dimension(:,:), intent(in) :: map
integer, intent(in), optional :: offset
call color_translate (qn%c, map, offset)
end subroutine quantum_numbers_translate_color1
@ %def quantum_numbers_translate_color
@ Inherited from the color component: return the color index with
highest absolute value.
Since the algorithm is not elemental, we keep the separate
procedures for different array rank.
<<Quantum numbers: public>>=
public :: quantum_numbers_get_max_color_value
<<Quantum numbers: interfaces>>=
interface quantum_numbers_get_max_color_value
module procedure quantum_numbers_get_max_color_value0
module procedure quantum_numbers_get_max_color_value1
module procedure quantum_numbers_get_max_color_value2
end interface
<<Quantum numbers: sub interfaces>>=
pure module function quantum_numbers_get_max_color_value0 (qn) result (cmax)
integer :: cmax
type(quantum_numbers_t), intent(in) :: qn
end function quantum_numbers_get_max_color_value0
pure module function quantum_numbers_get_max_color_value1 (qn) result (cmax)
integer :: cmax
type(quantum_numbers_t), dimension(:), intent(in) :: qn
end function quantum_numbers_get_max_color_value1
pure module function quantum_numbers_get_max_color_value2 (qn) result (cmax)
integer :: cmax
type(quantum_numbers_t), dimension(:,:), intent(in) :: qn
end function quantum_numbers_get_max_color_value2
<<Quantum numbers: procedures>>=
pure module function quantum_numbers_get_max_color_value0 (qn) result (cmax)
integer :: cmax
type(quantum_numbers_t), intent(in) :: qn
cmax = color_get_max_value (qn%c)
end function quantum_numbers_get_max_color_value0
pure module function quantum_numbers_get_max_color_value1 (qn) result (cmax)
integer :: cmax
type(quantum_numbers_t), dimension(:), intent(in) :: qn
cmax = color_get_max_value (qn%c)
end function quantum_numbers_get_max_color_value1
pure module function quantum_numbers_get_max_color_value2 (qn) result (cmax)
integer :: cmax
type(quantum_numbers_t), dimension(:,:), intent(in) :: qn
cmax = color_get_max_value (qn%c)
end function quantum_numbers_get_max_color_value2
@ Inherited from the color component: add an offset to the indices of
the color part
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: add_color_offset => quantum_numbers_add_color_offset
<<Quantum numbers: sub interfaces>>=
elemental module subroutine quantum_numbers_add_color_offset (qn, offset)
class(quantum_numbers_t), intent(inout) :: qn
integer, intent(in) :: offset
end subroutine quantum_numbers_add_color_offset
<<Quantum numbers: procedures>>=
elemental module subroutine quantum_numbers_add_color_offset (qn, offset)
class(quantum_numbers_t), intent(inout) :: qn
integer, intent(in) :: offset
call qn%c%add_offset (offset)
end subroutine quantum_numbers_add_color_offset
@ %def quantum_numbers_add_color_offset
@ Given a quantum number array, return all possible color
contractions, leaving the other quantum numbers intact.
<<Quantum numbers: public>>=
public :: quantum_number_array_make_color_contractions
<<Quantum numbers: sub interfaces>>=
module subroutine quantum_number_array_make_color_contractions (qn_in, qn_out)
type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
type(quantum_numbers_t), dimension(:,:), intent(out), allocatable :: qn_out
end subroutine quantum_number_array_make_color_contractions
<<Quantum numbers: procedures>>=
module subroutine quantum_number_array_make_color_contractions (qn_in, qn_out)
type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
type(quantum_numbers_t), dimension(:,:), intent(out), allocatable :: qn_out
type(color_t), dimension(:,:), allocatable :: col
integer :: i
call color_array_make_contractions (qn_in%c, col)
allocate (qn_out (size (col, 1), size (col, 2)))
do i = 1, size (qn_out, 2)
qn_out(:,i)%f = qn_in%f
qn_out(:,i)%c = col(:,i)
qn_out(:,i)%h = qn_in%h
end do
end subroutine quantum_number_array_make_color_contractions
@ %def quantum_number_array_make_color_contractions
@ Inherited from the color component: invert the color, switching
particle/antiparticle.
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: invert_color => quantum_numbers_invert_color
<<Quantum numbers: sub interfaces>>=
elemental module subroutine quantum_numbers_invert_color (qn)
class(quantum_numbers_t), intent(inout) :: qn
end subroutine quantum_numbers_invert_color
<<Quantum numbers: procedures>>=
elemental module subroutine quantum_numbers_invert_color (qn)
class(quantum_numbers_t), intent(inout) :: qn
call qn%c%invert ()
end subroutine quantum_numbers_invert_color
@ %def quantum_numbers_invert_color
@ Flip helicity.
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: flip_helicity => quantum_numbers_flip_helicity
<<Quantum numbers: sub interfaces>>=
elemental module subroutine quantum_numbers_flip_helicity (qn)
class(quantum_numbers_t), intent(inout) :: qn
end subroutine quantum_numbers_flip_helicity
<<Quantum numbers: procedures>>=
elemental module subroutine quantum_numbers_flip_helicity (qn)
class(quantum_numbers_t), intent(inout) :: qn
call qn%h%flip ()
end subroutine quantum_numbers_flip_helicity
@ %def quantum_numbers_flip_helicity
@
Merge two quantum number sets: for each entry, if both are defined,
combine them to an off-diagonal entry (meaningful only if the input
was diagonal). If either entry is undefined, take the defined
one.
For flavor, off-diagonal entries are invalid, so both
flavors must be equal, otherwise an invalid flavor is inserted.
<<Quantum numbers: public>>=
public :: operator(.merge.)
<<Quantum numbers: interfaces>>=
interface operator(.merge.)
module procedure merge_quantum_numbers0
module procedure merge_quantum_numbers1
end interface
<<Quantum numbers: sub interfaces>>=
module function merge_quantum_numbers0 (qn1, qn2) result (qn3)
type(quantum_numbers_t) :: qn3
type(quantum_numbers_t), intent(in) :: qn1, qn2
end function merge_quantum_numbers0
module function merge_quantum_numbers1 (qn1, qn2) result (qn3)
type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2
type(quantum_numbers_t), dimension(size(qn1)) :: qn3
end function merge_quantum_numbers1
<<Quantum numbers: procedures>>=
module function merge_quantum_numbers0 (qn1, qn2) result (qn3)
type(quantum_numbers_t) :: qn3
type(quantum_numbers_t), intent(in) :: qn1, qn2
qn3%f = qn1%f .merge. qn2%f
qn3%c = qn1%c .merge. qn2%c
qn3%h = qn1%h .merge. qn2%h
qn3%sub = merge_subtraction_index (qn1%sub, qn2%sub)
end function merge_quantum_numbers0
module function merge_quantum_numbers1 (qn1, qn2) result (qn3)
type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2
type(quantum_numbers_t), dimension(size(qn1)) :: qn3
qn3%f = qn1%f .merge. qn2%f
qn3%c = qn1%c .merge. qn2%c
qn3%h = qn1%h .merge. qn2%h
qn3%sub = merge_subtraction_index (qn1%sub, qn2%sub)
end function merge_quantum_numbers1
@ %def merge_quantum_numbers
@
<<Quantum numbers: procedures>>=
elemental function merge_subtraction_index (sub1, sub2) result (sub3)
integer :: sub3
integer, intent(in) :: sub1, sub2
if (sub1 > 0 .and. sub2 > 0) then
if (sub1 == sub2) then
sub3 = sub1
else
sub3 = 0
end if
else if (sub1 > 0) then
sub3 = sub1
else if (sub2 > 0) then
sub3 = sub2
else
sub3 = 0
end if
end function merge_subtraction_index
@ %def merge_subtraction_index
@
\subsection{The quantum number mask}
The quantum numbers mask is true for quantum numbers that should be
ignored or summed over. The three mandatory entries correspond to
flavor, color, and helicity, respectively.
There is an additional entry [[cg]]: If false, the color-ghosts
property should be kept even if color is ignored. This is relevant
only if [[c]] is set, otherwise it is always false.
The flag [[hd]] tells that only diagonal entries in helicity should be
kept. If [[h]] is set, [[hd]] is irrelevant and will be kept
[[.false.]]
<<Quantum numbers: public>>=
public :: quantum_numbers_mask_t
<<Quantum numbers: types>>=
type :: quantum_numbers_mask_t
private
logical :: f = .false.
logical :: c = .false.
logical :: cg = .false.
logical :: h = .false.
logical :: hd = .false.
integer :: sub = 0
contains
<<Quantum numbers: quantum numbers mask: TBP>>
end type quantum_numbers_mask_t
-@ %def quantum_number_t
+@ %def quantum_numbers_mask_t
@ Define a quantum number mask: Constructor form
<<Quantum numbers: public>>=
public :: quantum_numbers_mask
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_mask &
(mask_f, mask_c, mask_h, mask_cg, mask_hd) result (mask)
type(quantum_numbers_mask_t) :: mask
logical, intent(in) :: mask_f, mask_c, mask_h
logical, intent(in), optional :: mask_cg
logical, intent(in), optional :: mask_hd
end function quantum_numbers_mask
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_mask &
(mask_f, mask_c, mask_h, mask_cg, mask_hd) result (mask)
type(quantum_numbers_mask_t) :: mask
logical, intent(in) :: mask_f, mask_c, mask_h
logical, intent(in), optional :: mask_cg
logical, intent(in), optional :: mask_hd
call quantum_numbers_mask_init &
(mask, mask_f, mask_c, mask_h, mask_cg, mask_hd)
end function quantum_numbers_mask
@ %def new_quantum_numbers_mask
@ Define quantum numbers: Initializer form
<<Quantum numbers: quantum numbers mask: TBP>>=
procedure :: init => quantum_numbers_mask_init
<<Quantum numbers: sub interfaces>>=
elemental module subroutine quantum_numbers_mask_init &
(mask, mask_f, mask_c, mask_h, mask_cg, mask_hd)
class(quantum_numbers_mask_t), intent(inout) :: mask
logical, intent(in) :: mask_f, mask_c, mask_h
logical, intent(in), optional :: mask_cg, mask_hd
end subroutine quantum_numbers_mask_init
<<Quantum numbers: procedures>>=
elemental module subroutine quantum_numbers_mask_init &
(mask, mask_f, mask_c, mask_h, mask_cg, mask_hd)
class(quantum_numbers_mask_t), intent(inout) :: mask
logical, intent(in) :: mask_f, mask_c, mask_h
logical, intent(in), optional :: mask_cg, mask_hd
mask%f = mask_f
mask%c = mask_c
mask%h = mask_h
mask%cg = .false.
if (present (mask_cg)) then
if (mask%c) mask%cg = mask_cg
else
mask%cg = mask_c
end if
mask%hd = .false.
if (present (mask_hd)) then
if (.not. mask%h) mask%hd = mask_hd
end if
end subroutine quantum_numbers_mask_init
@ %def quantum_numbers_mask_init
@ Write a quantum numbers mask. We need the stand-alone subroutine for the
array case.
<<Quantum numbers: public>>=
public :: quantum_numbers_mask_write
<<Quantum numbers: interfaces>>=
interface quantum_numbers_mask_write
module procedure quantum_numbers_mask_write_single
module procedure quantum_numbers_mask_write_array
end interface
<<Quantum numbers: quantum numbers mask: TBP>>=
procedure :: write => quantum_numbers_mask_write_single
<<Quantum numbers: sub interfaces>>=
module subroutine quantum_numbers_mask_write_single (mask, unit)
class(quantum_numbers_mask_t), intent(in) :: mask
integer, intent(in), optional :: unit
end subroutine quantum_numbers_mask_write_single
module subroutine quantum_numbers_mask_write_array (mask, unit)
type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
integer, intent(in), optional :: unit
end subroutine quantum_numbers_mask_write_array
<<Quantum numbers: procedures>>=
module subroutine quantum_numbers_mask_write_single (mask, unit)
class(quantum_numbers_mask_t), intent(in) :: mask
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(A)", advance="no") "["
write (u, "(L1)", advance="no") mask%f
write (u, "(L1)", advance="no") mask%c
if (.not.mask%cg) write (u, "('g')", advance="no")
write (u, "(L1)", advance="no") mask%h
if (mask%hd) write (u, "('d')", advance="no")
write (u, "(A)", advance="no") "]"
end subroutine quantum_numbers_mask_write_single
module subroutine quantum_numbers_mask_write_array (mask, unit)
type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(A)", advance="no") "["
do i = 1, size (mask)
if (i > 1) write (u, "(A)", advance="no") "/"
write (u, "(L1)", advance="no") mask(i)%f
write (u, "(L1)", advance="no") mask(i)%c
if (.not.mask(i)%cg) write (u, "('g')", advance="no")
write (u, "(L1)", advance="no") mask(i)%h
if (mask(i)%hd) write (u, "('d')", advance="no")
end do
write (u, "(A)", advance="no") "]"
end subroutine quantum_numbers_mask_write_array
@ %def quantum_numbers_mask_write
@
\subsection{Setting mask components}
<<Quantum numbers: quantum numbers mask: TBP>>=
procedure :: set_flavor => quantum_numbers_mask_set_flavor
procedure :: set_color => quantum_numbers_mask_set_color
procedure :: set_helicity => quantum_numbers_mask_set_helicity
procedure :: set_sub => quantum_numbers_mask_set_sub
<<Quantum numbers: sub interfaces>>=
elemental module subroutine quantum_numbers_mask_set_flavor (mask, mask_f)
class(quantum_numbers_mask_t), intent(inout) :: mask
logical, intent(in) :: mask_f
end subroutine quantum_numbers_mask_set_flavor
elemental module subroutine quantum_numbers_mask_set_color (mask, mask_c, mask_cg)
class(quantum_numbers_mask_t), intent(inout) :: mask
logical, intent(in) :: mask_c
logical, intent(in), optional :: mask_cg
end subroutine quantum_numbers_mask_set_color
elemental module subroutine quantum_numbers_mask_set_helicity (mask, mask_h, mask_hd)
class(quantum_numbers_mask_t), intent(inout) :: mask
logical, intent(in) :: mask_h
logical, intent(in), optional :: mask_hd
end subroutine quantum_numbers_mask_set_helicity
elemental module subroutine quantum_numbers_mask_set_sub (mask, sub)
class(quantum_numbers_mask_t), intent(inout) :: mask
integer, intent(in) :: sub
end subroutine quantum_numbers_mask_set_sub
<<Quantum numbers: procedures>>=
elemental module subroutine quantum_numbers_mask_set_flavor (mask, mask_f)
class(quantum_numbers_mask_t), intent(inout) :: mask
logical, intent(in) :: mask_f
mask%f = mask_f
end subroutine quantum_numbers_mask_set_flavor
elemental module subroutine quantum_numbers_mask_set_color (mask, mask_c, mask_cg)
class(quantum_numbers_mask_t), intent(inout) :: mask
logical, intent(in) :: mask_c
logical, intent(in), optional :: mask_cg
mask%c = mask_c
if (present (mask_cg)) then
if (mask%c) mask%cg = mask_cg
else
mask%cg = mask_c
end if
end subroutine quantum_numbers_mask_set_color
elemental module subroutine quantum_numbers_mask_set_helicity (mask, mask_h, mask_hd)
class(quantum_numbers_mask_t), intent(inout) :: mask
logical, intent(in) :: mask_h
logical, intent(in), optional :: mask_hd
mask%h = mask_h
if (present (mask_hd)) then
if (.not. mask%h) mask%hd = mask_hd
end if
end subroutine quantum_numbers_mask_set_helicity
elemental module subroutine quantum_numbers_mask_set_sub (mask, sub)
class(quantum_numbers_mask_t), intent(inout) :: mask
integer, intent(in) :: sub
mask%sub = sub
end subroutine quantum_numbers_mask_set_sub
@ %def quantum_numbers_mask_set_flavor
@ %def quantum_numbers_mask_set_color
@ %def quantum_numbers_mask_set_helicity
@ %def quantum_numbers_mask_set_sub
@ The following routines assign part of a mask, depending on the flags given.
<<Quantum numbers: quantum numbers mask: TBP>>=
procedure :: assign => quantum_numbers_mask_assign
<<Quantum numbers: sub interfaces>>=
elemental module subroutine quantum_numbers_mask_assign &
(mask, mask_in, flavor, color, helicity)
class(quantum_numbers_mask_t), intent(inout) :: mask
class(quantum_numbers_mask_t), intent(in) :: mask_in
logical, intent(in), optional :: flavor, color, helicity
end subroutine quantum_numbers_mask_assign
<<Quantum numbers: procedures>>=
elemental module subroutine quantum_numbers_mask_assign &
(mask, mask_in, flavor, color, helicity)
class(quantum_numbers_mask_t), intent(inout) :: mask
class(quantum_numbers_mask_t), intent(in) :: mask_in
logical, intent(in), optional :: flavor, color, helicity
if (present (flavor)) then
if (flavor) then
mask%f = mask_in%f
end if
end if
if (present (color)) then
if (color) then
mask%c = mask_in%c
mask%cg = mask_in%cg
end if
end if
if (present (helicity)) then
if (helicity) then
mask%h = mask_in%h
mask%hd = mask_in%hd
end if
end if
end subroutine quantum_numbers_mask_assign
@ %def quantum_numbers_mask_assign
@
\subsection{Mask predicates}
Return true if either one of the entries is set:
<<Quantum numbers: public>>=
public :: any
<<Quantum numbers: interfaces>>=
interface any
module procedure quantum_numbers_mask_any
end interface
<<Quantum numbers: sub interfaces>>=
module function quantum_numbers_mask_any (mask) result (match)
logical :: match
type(quantum_numbers_mask_t), intent(in) :: mask
end function quantum_numbers_mask_any
<<Quantum numbers: procedures>>=
module function quantum_numbers_mask_any (mask) result (match)
logical :: match
type(quantum_numbers_mask_t), intent(in) :: mask
match = mask%f .or. mask%c .or. mask%h .or. mask%hd
end function quantum_numbers_mask_any
@ %def any
@
\subsection{Operators}
The OR operation is applied to all components.
<<Quantum numbers: quantum numbers mask: TBP>>=
generic :: operator(.or.) => quantum_numbers_mask_or
procedure, private :: quantum_numbers_mask_or
@ %def .or.
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_mask_or (mask1, mask2) result (mask)
type(quantum_numbers_mask_t) :: mask
class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
end function quantum_numbers_mask_or
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_mask_or (mask1, mask2) result (mask)
type(quantum_numbers_mask_t) :: mask
class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
mask%f = mask1%f .or. mask2%f
mask%c = mask1%c .or. mask2%c
if (mask%c) mask%cg = mask1%cg .or. mask2%cg
mask%h = mask1%h .or. mask2%h
if (.not. mask%h) mask%hd = mask1%hd .or. mask2%hd
end function quantum_numbers_mask_or
@ %def quantum_numbers_mask_or
@
\subsection{Mask comparisons}
Return true if the two masks are equivalent / differ:
<<Quantum numbers: quantum numbers mask: TBP>>=
generic :: operator(.eqv.) => quantum_numbers_mask_eqv
generic :: operator(.neqv.) => quantum_numbers_mask_neqv
procedure, private :: quantum_numbers_mask_eqv
procedure, private :: quantum_numbers_mask_neqv
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_mask_eqv (mask1, mask2) result (eqv)
logical :: eqv
class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
end function quantum_numbers_mask_eqv
elemental module function quantum_numbers_mask_neqv (mask1, mask2) result (neqv)
logical :: neqv
class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
end function quantum_numbers_mask_neqv
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_mask_eqv (mask1, mask2) result (eqv)
logical :: eqv
class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
eqv = (mask1%f .eqv. mask2%f) .and. &
(mask1%c .eqv. mask2%c) .and. &
(mask1%cg .eqv. mask2%cg) .and. &
(mask1%h .eqv. mask2%h) .and. &
(mask1%hd .eqv. mask2%hd)
end function quantum_numbers_mask_eqv
elemental module function quantum_numbers_mask_neqv (mask1, mask2) result (neqv)
logical :: neqv
class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
neqv = (mask1%f .neqv. mask2%f) .or. &
(mask1%c .neqv. mask2%c) .or. &
(mask1%cg .neqv. mask2%cg) .or. &
(mask1%h .neqv. mask2%h) .or. &
(mask1%hd .neqv. mask2%hd)
end function quantum_numbers_mask_neqv
@ %def .eqv. .neqv.
@
\subsection{Apply a mask}
Applying a mask to the quantum number object means undefining those
entries where the mask is set. The others remain unaffected.
The [[hd]] mask has the special property that it ``diagonalizes''
helicity, i.e., the second helicity entry is dropped and the result is
a diagonal helicity quantum number.
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: undefine => quantum_numbers_undefine
procedure :: undefined => quantum_numbers_undefined0
<<Quantum numbers: public>>=
public :: quantum_numbers_undefined
<<Quantum numbers: interfaces>>=
interface quantum_numbers_undefined
module procedure quantum_numbers_undefined0
module procedure quantum_numbers_undefined1
module procedure quantum_numbers_undefined11
end interface
<<Quantum numbers: sub interfaces>>=
elemental module subroutine quantum_numbers_undefine (qn, mask)
class(quantum_numbers_t), intent(inout) :: qn
type(quantum_numbers_mask_t), intent(in) :: mask
end subroutine quantum_numbers_undefine
module function quantum_numbers_undefined0 (qn, mask) result (qn_new)
class(quantum_numbers_t), intent(in) :: qn
type(quantum_numbers_mask_t), intent(in) :: mask
type(quantum_numbers_t) :: qn_new
end function quantum_numbers_undefined0
module function quantum_numbers_undefined1 (qn, mask) result (qn_new)
type(quantum_numbers_t), dimension(:), intent(in) :: qn
type(quantum_numbers_mask_t), intent(in) :: mask
type(quantum_numbers_t), dimension(size(qn)) :: qn_new
end function quantum_numbers_undefined1
module function quantum_numbers_undefined11 (qn, mask) result (qn_new)
type(quantum_numbers_t), dimension(:), intent(in) :: qn
type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
type(quantum_numbers_t), dimension(size(qn)) :: qn_new
end function quantum_numbers_undefined11
<<Quantum numbers: procedures>>=
elemental module subroutine quantum_numbers_undefine (qn, mask)
class(quantum_numbers_t), intent(inout) :: qn
type(quantum_numbers_mask_t), intent(in) :: mask
if (mask%f) call qn%f%undefine ()
if (mask%c) call qn%c%undefine (undefine_ghost = mask%cg)
if (mask%h) then
call qn%h%undefine ()
else if (mask%hd) then
if (.not. qn%h%is_diagonal ()) then
call qn%h%diagonalize ()
end if
end if
if (mask%sub > 0) qn%sub = 0
end subroutine quantum_numbers_undefine
module function quantum_numbers_undefined0 (qn, mask) result (qn_new)
class(quantum_numbers_t), intent(in) :: qn
type(quantum_numbers_mask_t), intent(in) :: mask
type(quantum_numbers_t) :: qn_new
select type (qn)
type is (quantum_numbers_t); qn_new = qn
end select
call quantum_numbers_undefine (qn_new, mask)
end function quantum_numbers_undefined0
module function quantum_numbers_undefined1 (qn, mask) result (qn_new)
type(quantum_numbers_t), dimension(:), intent(in) :: qn
type(quantum_numbers_mask_t), intent(in) :: mask
type(quantum_numbers_t), dimension(size(qn)) :: qn_new
qn_new = qn
call quantum_numbers_undefine (qn_new, mask)
end function quantum_numbers_undefined1
module function quantum_numbers_undefined11 (qn, mask) result (qn_new)
type(quantum_numbers_t), dimension(:), intent(in) :: qn
type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
type(quantum_numbers_t), dimension(size(qn)) :: qn_new
qn_new = qn
call quantum_numbers_undefine (qn_new, mask)
end function quantum_numbers_undefined11
@ %def quantum_numbers_undefine
@ %def quantum_numbers_undefined
@ Return true if the input quantum number set has entries that would
be removed by the applied mask, e.g., if polarization is defined but
[[mask%h]] is set:
<<Quantum numbers: quantum numbers: TBP>>=
procedure :: are_redundant => quantum_numbers_are_redundant
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_are_redundant (qn, mask) &
result (redundant)
logical :: redundant
class(quantum_numbers_t), intent(in) :: qn
type(quantum_numbers_mask_t), intent(in) :: mask
end function quantum_numbers_are_redundant
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_are_redundant (qn, mask) &
result (redundant)
logical :: redundant
class(quantum_numbers_t), intent(in) :: qn
type(quantum_numbers_mask_t), intent(in) :: mask
redundant = .false.
if (mask%f) then
redundant = qn%f%is_defined ()
end if
if (mask%c) then
redundant = qn%c%is_defined ()
end if
if (mask%h) then
redundant = qn%h%is_defined ()
else if (mask%hd) then
redundant = .not. qn%h%is_diagonal ()
end if
if (mask%sub > 0) redundant = qn%sub >= mask%sub
end function quantum_numbers_are_redundant
@ %def quantum_numbers_are_redundant
@ Return true if the helicity flag is set or the diagonal-helicity flag is
set.
<<Quantum numbers: quantum numbers mask: TBP>>=
procedure :: diagonal_helicity => quantum_numbers_mask_diagonal_helicity
<<Quantum numbers: sub interfaces>>=
elemental module function quantum_numbers_mask_diagonal_helicity (mask) &
result (flag)
logical :: flag
class(quantum_numbers_mask_t), intent(in) :: mask
end function quantum_numbers_mask_diagonal_helicity
<<Quantum numbers: procedures>>=
elemental module function quantum_numbers_mask_diagonal_helicity (mask) &
result (flag)
logical :: flag
class(quantum_numbers_mask_t), intent(in) :: mask
flag = mask%h .or. mask%hd
end function quantum_numbers_mask_diagonal_helicity
@ %def quantum_numbers_mask_diagonal_helicity
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Transition Matrices and Evaluation}
The modules in this chapter implement transition matrices and calculations.
The functionality is broken down in three modules
\begin{description}
\item[state\_matrices]
represent state and transition density matrices built from particle quantum
numbers (helicity, color, flavor)
\item[interactions]
extend state matrices with the record of particle momenta. They also
distinguish in- and out-particles and store parent-child relations.
\item[evaluators]
These objects extend interaction objects by the information how to calculate
matrix elements from products and squares of other interactions. They
implement the methods to actually compute those matrix elements.
\end{description}
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{State matrices}
This module deals with the internal state of a particle system, i.e.,
with its density matrix in flavor, color, and helicity space.
<<[[state_matrices.f90]]>>=
<<File header>>
module state_matrices
<<Use kinds>>
use model_data
use flavors
use colors
use helicities
use quantum_numbers
<<Standard module head>>
<<State matrices: public>>
<<State matrices: parameters>>
<<State matrices: types>>
<<State matrices: interfaces>>
interface
<<State matrices: sub interfaces>>
end interface
end module state_matrices
@ %def state_matrices
@
<<[[state_matrices_sub.f90]]>>=
<<File header>>
submodule (state_matrices) state_matrices_s
use constants, only: zero
use format_utils, only: pac_fmt
use format_defs, only: FMT_17, FMT_19
use io_units
use diagnostics
use sorting
implicit none
contains
<<State matrices: procedures>>
end submodule state_matrices_s
@ %def state_matrices_s
@
\subsection{Nodes of the quantum state trie}
A quantum state object represents an unnormalized density matrix,
i.e., an array of possibilities for flavor, color, and helicity
indices with associated complex values. Physically, the trace of this
matrix is the summed squared matrix element for an interaction, and
the matrix elements divided by this value correspond to the
flavor-color-helicity density matrix. (Flavor and color are
diagonal.)
We store density matrices as tries, that is, as trees where each
branching represents the possible quantum numbers of a particle. The
first branching is the first particle in the system. A leaf (the node
corresponding to the last particle) contains the value of the matrix
element.
Each node contains a flavor, color, and helicity entry. Note that
each of those entries may be actually undefined, so we can also represent,
e.g., unpolarized particles.
The value is meaningful only for leaves, which have no child nodes.
There is a pointer to the parent node which allows for following the
trie downwards from a leaf, it is null for a root node. The child
nodes are implemented as a list, so there is a pointer to the first
and last child, and each node also has a [[next]] pointer to the next
sibling.
The root node does not correspond to a particle, only its children do.
The quantum numbers of the root node are irrelevant and will not be
set. However, we use a common type for the three classes (root,
branch, leaf); they may easily be distinguished by the association
status of parent and child.
\subsubsection{Node type}
The node is linked in all directions: the parent, the first and last
in the list of children, and the previous and next sibling. This allows
us for adding and removing nodes and whole branches anywhere in the
trie. (Circular links are not allowed, however.). The node holds its
associated set of quantum numbers. The integer index, which is set
only for leaf nodes, is the index of the corresponding matrix element
value within the state matrix.
Temporarily, matrix-element values may be stored within a leaf node.
This is used during state-matrix factorization. When the state matrix
is [[freeze]]d, these values are transferred to the matrix-element
array within the host state matrix.
<<State matrices: types>>=
type :: node_t
private
type(quantum_numbers_t) :: qn
type(node_t), pointer :: parent => null ()
type(node_t), pointer :: child_first => null ()
type(node_t), pointer :: child_last => null ()
type(node_t), pointer :: next => null ()
type(node_t), pointer :: previous => null ()
integer :: me_index = 0
integer, dimension(:), allocatable :: me_count
complex(default) :: me = 0
end type node_t
@ %def node_t
@
\subsubsection{Operations on nodes}
Recursively deallocate all children of the current
node. This includes any values associated with the children.
<<State matrices: procedures>>=
pure recursive subroutine node_delete_offspring (node)
type(node_t), pointer :: node
type(node_t), pointer :: child
child => node%child_first
do while (associated (child))
node%child_first => node%child_first%next
call node_delete_offspring (child)
deallocate (child)
child => node%child_first
end do
node%child_last => null ()
end subroutine node_delete_offspring
@ %def node_delete_offspring
@ Remove a node including its offspring. Adjust the pointers of
parent and siblings, if necessary.
<<State matrices: procedures>>=
pure subroutine node_delete (node)
type(node_t), pointer :: node
call node_delete_offspring (node)
if (associated (node%previous)) then
node%previous%next => node%next
else if (associated (node%parent)) then
node%parent%child_first => node%next
end if
if (associated (node%next)) then
node%next%previous => node%previous
else if (associated (node%parent)) then
node%parent%child_last => node%previous
end if
deallocate (node)
end subroutine node_delete
@ %def node_delete
@ Append a child node
<<State matrices: procedures>>=
subroutine node_append_child (node, child)
type(node_t), target, intent(inout) :: node
type(node_t), pointer :: child
allocate (child)
if (associated (node%child_last)) then
node%child_last%next => child
child%previous => node%child_last
else
node%child_first => child
end if
node%child_last => child
child%parent => node
end subroutine node_append_child
@ %def node_append_child
@
\subsubsection{I/O}
Output of a single node, no recursion. We print the quantum numbers
in square brackets, then the value (if any).
<<State matrices: procedures>>=
subroutine node_write (node, me_array, verbose, unit, col_verbose, testflag)
type(node_t), intent(in) :: node
complex(default), dimension(:), intent(in), optional :: me_array
logical, intent(in), optional :: verbose, col_verbose, testflag
integer, intent(in), optional :: unit
logical :: verb
integer :: u
character(len=7) :: fmt
call pac_fmt (fmt, FMT_19, FMT_17, testflag)
verb = .false.; if (present (verbose)) verb = verbose
u = given_output_unit (unit); if (u < 0) return
call node%qn%write (u, col_verbose)
if (node%me_index /= 0) then
write (u, "(A,I0,A)", advance="no") " => ME(", node%me_index, ")"
if (present (me_array)) then
write (u, "(A)", advance="no") " = "
write (u, "('('," // fmt // ",','," // fmt // ",')')", &
advance="no") pacify_complex (me_array(node%me_index))
end if
end if
write (u, *)
if (verb) then
call ptr_write ("parent ", node%parent)
call ptr_write ("child_first", node%child_first)
call ptr_write ("child_last ", node%child_last)
call ptr_write ("next ", node%next)
call ptr_write ("previous ", node%previous)
end if
contains
subroutine ptr_write (label, node)
character(*), intent(in) :: label
type(node_t), pointer :: node
if (associated (node)) then
write (u, "(10x,A,1x,'->',1x)", advance="no") label
call node%qn%write (u, col_verbose)
write (u, *)
end if
end subroutine ptr_write
end subroutine node_write
@ %def node_write
@ Recursive output of a node:
<<State matrices: procedures>>=
recursive subroutine node_write_rec (node, me_array, verbose, &
indent, unit, col_verbose, testflag)
type(node_t), intent(in), target :: node
complex(default), dimension(:), intent(in), optional :: me_array
logical, intent(in), optional :: verbose, col_verbose, testflag
integer, intent(in), optional :: indent
integer, intent(in), optional :: unit
type(node_t), pointer :: current
logical :: verb
integer :: i, u
verb = .false.; if (present (verbose)) verb = verbose
i = 0; if (present (indent)) i = indent
u = given_output_unit (unit); if (u < 0) return
current => node%child_first
do while (associated (current))
write (u, "(A)", advance="no") repeat (" ", i)
call node_write (current, me_array, verbose = verb, &
unit = u, col_verbose = col_verbose, testflag = testflag)
call node_write_rec (current, me_array, verbose = verb, &
indent = i + 2, unit = u, col_verbose = col_verbose, testflag = testflag)
current => current%next
end do
end subroutine node_write_rec
@ %def node_write_rec
@ Binary I/O. Matrix elements are written only for leaf nodes.
<<State matrices: procedures>>=
recursive subroutine node_write_raw_rec (node, u)
type(node_t), intent(in), target :: node
integer, intent(in) :: u
logical :: associated_child_first, associated_next
call node%qn%write_raw (u)
associated_child_first = associated (node%child_first)
write (u) associated_child_first
associated_next = associated (node%next)
write (u) associated_next
if (associated_child_first) then
call node_write_raw_rec (node%child_first, u)
else
write (u) node%me_index
write (u) node%me
end if
if (associated_next) then
call node_write_raw_rec (node%next, u)
end if
end subroutine node_write_raw_rec
recursive subroutine node_read_raw_rec (node, u, parent, iostat)
type(node_t), intent(out), target :: node
integer, intent(in) :: u
type(node_t), intent(in), optional, target :: parent
integer, intent(out), optional :: iostat
logical :: associated_child_first, associated_next
type(node_t), pointer :: child
call node%qn%read_raw (u, iostat=iostat)
read (u, iostat=iostat) associated_child_first
read (u, iostat=iostat) associated_next
if (present (parent)) node%parent => parent
if (associated_child_first) then
allocate (child)
node%child_first => child
node%child_last => null ()
call node_read_raw_rec (child, u, node, iostat=iostat)
do while (associated (child))
child%previous => node%child_last
node%child_last => child
child => child%next
end do
else
read (u, iostat=iostat) node%me_index
read (u, iostat=iostat) node%me
end if
if (associated_next) then
allocate (node%next)
call node_read_raw_rec (node%next, u, parent, iostat=iostat)
end if
end subroutine node_read_raw_rec
@ %def node_write_raw
@
\subsection{State matrix}
\subsubsection{Definition}
The quantum state object is a container that keeps and hides the root
node. For direct accessibility of values, they are stored
in a separate array. The leaf nodes of the quantum-number tree point to those
values, once the state matrix is finalized.
The [[norm]] component is redefined if a common factor is extracted from all
nodes.
<<State matrices: public>>=
public :: state_matrix_t
<<State matrices: types>>=
type :: state_matrix_t
private
type(node_t), pointer :: root => null ()
integer :: depth = 0
integer :: n_matrix_elements = 0
logical :: leaf_nodes_store_values = .false.
integer :: n_counters = 0
complex(default), dimension(:), allocatable :: me
real(default) :: norm = 1
integer :: n_sub = -1
contains
<<State matrices: state matrix: TBP>>
end type state_matrix_t
@ %def state_matrix_t
@ This initializer allocates the root node but does not fill
anything. We declare whether values are stored within the nodes
during state-matrix construction, and how many counters should be
maintained (default: none).
<<State matrices: state matrix: TBP>>=
procedure :: init => state_matrix_init
<<State matrices: sub interfaces>>=
module subroutine state_matrix_init (state, store_values, n_counters)
class(state_matrix_t), intent(out) :: state
logical, intent(in), optional :: store_values
integer, intent(in), optional :: n_counters
end subroutine state_matrix_init
<<State matrices: procedures>>=
module subroutine state_matrix_init (state, store_values, n_counters)
class(state_matrix_t), intent(out) :: state
logical, intent(in), optional :: store_values
integer, intent(in), optional :: n_counters
allocate (state%root)
if (present (store_values)) &
state%leaf_nodes_store_values = store_values
if (present (n_counters)) state%n_counters = n_counters
end subroutine state_matrix_init
@ %def state_matrix_init
@ This recursively deletes all children of the root node, restoring
the initial state. The matrix element array is not finalized, since
it does not contain physical entries, just pointers.
<<State matrices: state matrix: TBP>>=
procedure :: final => state_matrix_final
<<State matrices: sub interfaces>>=
module subroutine state_matrix_final (state)
class(state_matrix_t), intent(inout) :: state
end subroutine state_matrix_final
<<State matrices: procedures>>=
module subroutine state_matrix_final (state)
class(state_matrix_t), intent(inout) :: state
if (allocated (state%me)) deallocate (state%me)
if (associated (state%root)) call node_delete (state%root)
state%depth = 0
state%n_matrix_elements = 0
end subroutine state_matrix_final
@ %def state_matrix_final
@ Output: Present the tree as a nested list with appropriate
indentation.
<<State matrices: state matrix: TBP>>=
procedure :: write => state_matrix_write
<<State matrices: sub interfaces>>=
module subroutine state_matrix_write (state, unit, write_value_list, &
verbose, col_verbose, testflag)
class(state_matrix_t), intent(in) :: state
logical, intent(in), optional :: write_value_list, verbose, col_verbose
logical, intent(in), optional :: testflag
integer, intent(in), optional :: unit
end subroutine state_matrix_write
<<State matrices: procedures>>=
module subroutine state_matrix_write (state, unit, write_value_list, &
verbose, col_verbose, testflag)
class(state_matrix_t), intent(in) :: state
logical, intent(in), optional :: write_value_list, verbose, col_verbose
logical, intent(in), optional :: testflag
integer, intent(in), optional :: unit
complex(default) :: me_dum
character(len=7) :: fmt
integer :: u
integer :: i
call pac_fmt (fmt, FMT_19, FMT_17, testflag)
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A," // fmt // ")") "State matrix: norm = ", state%norm
if (associated (state%root)) then
if (allocated (state%me)) then
call node_write_rec (state%root, state%me, verbose = verbose, &
indent = 1, unit = u, col_verbose = col_verbose, &
testflag = testflag)
else
call node_write_rec (state%root, verbose = verbose, indent = 1, &
unit = u, col_verbose = col_verbose, testflag = testflag)
end if
end if
if (present (write_value_list)) then
if (write_value_list .and. allocated (state%me)) then
do i = 1, size (state%me)
write (u, "(1x,I0,A)", advance="no") i, ":"
me_dum = state%me(i)
if (real(state%me(i)) == -real(state%me(i))) then
me_dum = &
cmplx (0._default, aimag(me_dum), kind=default)
end if
if (aimag(me_dum) == -aimag(me_dum)) then
me_dum = &
cmplx (real(me_dum), 0._default, kind=default)
end if
write (u, "('('," // fmt // ",','," // fmt // &
",')')") me_dum
end do
end if
end if
end subroutine state_matrix_write
@ %def state_matrix_write
@ Binary I/O. The auxiliary matrix-element array is not written, but
reconstructed after reading the tree.
Note: To be checked. Might be broken, don't use (unless trivial).
<<State matrices: state matrix: TBP>>=
procedure :: write_raw => state_matrix_write_raw
procedure :: read_raw => state_matrix_read_raw
<<State matrices: sub interfaces>>=
module subroutine state_matrix_write_raw (state, u)
class(state_matrix_t), intent(in), target :: state
integer, intent(in) :: u
end subroutine state_matrix_write_raw
module subroutine state_matrix_read_raw (state, u, iostat)
class(state_matrix_t), intent(out) :: state
integer, intent(in) :: u
integer, intent(out) :: iostat
end subroutine state_matrix_read_raw
<<State matrices: procedures>>=
module subroutine state_matrix_write_raw (state, u)
class(state_matrix_t), intent(in), target :: state
integer, intent(in) :: u
logical :: is_defined
integer :: depth, j
type(state_iterator_t) :: it
type(quantum_numbers_t), dimension(:), allocatable :: qn
is_defined = state%is_defined ()
write (u) is_defined
if (is_defined) then
write (u) state%get_norm ()
write (u) state%get_n_leaves ()
depth = state%get_depth ()
write (u) depth
allocate (qn (depth))
call it%init (state)
do while (it%is_valid ())
qn = it%get_quantum_numbers ()
do j = 1, depth
call qn(j)%write_raw (u)
end do
write (u) it%get_me_index ()
write (u) it%get_matrix_element ()
call it%advance ()
end do
end if
end subroutine state_matrix_write_raw
module subroutine state_matrix_read_raw (state, u, iostat)
class(state_matrix_t), intent(out) :: state
integer, intent(in) :: u
integer, intent(out) :: iostat
logical :: is_defined
real(default) :: norm
integer :: n_leaves, depth, i, j
type(quantum_numbers_t), dimension(:), allocatable :: qn
integer :: me_index
complex(default) :: me
read (u, iostat=iostat) is_defined
if (iostat /= 0) goto 1
if (is_defined) then
call state%init (store_values = .true.)
read (u, iostat=iostat) norm
if (iostat /= 0) goto 1
call state_matrix_set_norm (state, norm)
read (u) n_leaves
if (iostat /= 0) goto 1
read (u) depth
if (iostat /= 0) goto 1
allocate (qn (depth))
do i = 1, n_leaves
do j = 1, depth
call qn(j)%read_raw (u, iostat=iostat)
if (iostat /= 0) goto 1
end do
read (u, iostat=iostat) me_index
if (iostat /= 0) goto 1
read (u, iostat=iostat) me
if (iostat /= 0) goto 1
call state%add_state (qn, index = me_index, value = me)
end do
call state_matrix_freeze (state)
end if
return
! Clean up on error
1 continue
call state%final ()
end subroutine state_matrix_read_raw
@ %def state_matrix_write_raw state_matrix_read_raw
@ Assign a model pointer to all flavor entries. This will become
necessary when we have read a state matrix from file.
<<State matrices: state matrix: TBP>>=
procedure :: set_model => state_matrix_set_model
<<State matrices: sub interfaces>>=
module subroutine state_matrix_set_model (state, model)
class(state_matrix_t), intent(inout), target :: state
class(model_data_t), intent(in), target :: model
end subroutine state_matrix_set_model
<<State matrices: procedures>>=
module subroutine state_matrix_set_model (state, model)
class(state_matrix_t), intent(inout), target :: state
class(model_data_t), intent(in), target :: model
type(state_iterator_t) :: it
call it%init (state)
do while (it%is_valid ())
call it%set_model (model)
call it%advance ()
end do
end subroutine state_matrix_set_model
@ %def state_matrix_set_model
@ Iterate over [[state]], get the quantum numbers array [[qn]] for each iteration, and tag
all array elements of [[qn]] with the indizes given by [[tag]] as part of the hard interaction.
Then add them to [[tagged_state]] and return it. If no [[tag]] is given, tag all [[qn]] as
part of the hard process.
<<State matrices: state matrix: TBP>>=
procedure :: tag_hard_process => state_matrix_tag_hard_process
<<State matrices: sub interfaces>>=
module subroutine state_matrix_tag_hard_process (state, tagged_state, tag)
class(state_matrix_t), intent(in), target :: state
type(state_matrix_t), intent(out) :: tagged_state
integer, dimension(:), intent(in), optional :: tag
end subroutine state_matrix_tag_hard_process
<<State matrices: procedures>>=
module subroutine state_matrix_tag_hard_process (state, tagged_state, tag)
class(state_matrix_t), intent(in), target :: state
type(state_matrix_t), intent(out) :: tagged_state
integer, dimension(:), intent(in), optional :: tag
type(state_iterator_t) :: it
type(quantum_numbers_t), dimension(:), allocatable :: qn
complex(default) :: value
integer :: i
call tagged_state%init (store_values = .true.)
call it%init (state)
do while (it%is_valid ())
qn = it%get_quantum_numbers ()
value = it%get_matrix_element ()
if (present (tag)) then
do i = 1, size (tag)
call qn(tag(i))%tag_hard_process ()
end do
else
call qn%tag_hard_process ()
end if
call tagged_state%add_state (qn, index = it%get_me_index (), value = value)
call it%advance ()
end do
call tagged_state%freeze ()
end subroutine state_matrix_tag_hard_process
@ %def state_matrix_tag_hard_process
\subsubsection{Properties of the quantum state}
A state is defined if its root is allocated:
<<State matrices: state matrix: TBP>>=
procedure :: is_defined => state_matrix_is_defined
<<State matrices: sub interfaces>>=
elemental module function state_matrix_is_defined (state) result (defined)
logical :: defined
class(state_matrix_t), intent(in) :: state
end function state_matrix_is_defined
<<State matrices: procedures>>=
elemental module function state_matrix_is_defined (state) result (defined)
logical :: defined
class(state_matrix_t), intent(in) :: state
defined = associated (state%root)
end function state_matrix_is_defined
@ %def state_matrix_is_defined
@ A state is empty if its depth is zero:
<<State matrices: state matrix: TBP>>=
procedure :: is_empty => state_matrix_is_empty
<<State matrices: sub interfaces>>=
elemental module function state_matrix_is_empty (state) result (flag)
logical :: flag
class(state_matrix_t), intent(in) :: state
end function state_matrix_is_empty
<<State matrices: procedures>>=
elemental module function state_matrix_is_empty (state) result (flag)
logical :: flag
class(state_matrix_t), intent(in) :: state
flag = state%depth == 0
end function state_matrix_is_empty
@ %def state_matrix_is_empty
@ Return the number of matrix-element values.
<<State matrices: state matrix: TBP>>=
generic :: get_n_matrix_elements => get_n_matrix_elements_all, get_n_matrix_elements_mask
procedure :: get_n_matrix_elements_all => state_matrix_get_n_matrix_elements_all
procedure :: get_n_matrix_elements_mask => state_matrix_get_n_matrix_elements_mask
<<State matrices: sub interfaces>>=
pure module function state_matrix_get_n_matrix_elements_all (state) result (n)
integer :: n
class(state_matrix_t), intent(in) :: state
end function state_matrix_get_n_matrix_elements_all
<<State matrices: procedures>>=
pure module function state_matrix_get_n_matrix_elements_all (state) result (n)
integer :: n
class(state_matrix_t), intent(in) :: state
n = state%n_matrix_elements
end function state_matrix_get_n_matrix_elements_all
@ %def state_matrix_get_n_matrix_elements_all
@
<<State matrices: sub interfaces>>=
module function state_matrix_get_n_matrix_elements_mask (state, qn_mask) result (n)
integer :: n
class(state_matrix_t), intent(in) :: state
type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask
end function state_matrix_get_n_matrix_elements_mask
<<State matrices: procedures>>=
module function state_matrix_get_n_matrix_elements_mask (state, qn_mask) result (n)
integer :: n
class(state_matrix_t), intent(in) :: state
type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask
type(state_iterator_t) :: it
type(quantum_numbers_t), dimension(size(qn_mask)) :: qn
type(state_matrix_t) :: state_tmp
call state_tmp%init ()
call it%init (state)
do while (it%is_valid ())
qn = it%get_quantum_numbers ()
call qn%undefine (qn_mask)
call state_tmp%add_state (qn)
call it%advance ()
end do
n = state_tmp%n_matrix_elements
call state_tmp%final ()
end function state_matrix_get_n_matrix_elements_mask
@ %def state_matrix_get_n_matrix_elments_mask
@ Return the size of the [[me]]-array for debugging purposes.
<<State matrices: state matrix: TBP>>=
procedure :: get_me_size => state_matrix_get_me_size
<<State matrices: sub interfaces>>=
pure module function state_matrix_get_me_size (state) result (n)
integer :: n
class(state_matrix_t), intent(in) :: state
end function state_matrix_get_me_size
<<State matrices: procedures>>=
pure module function state_matrix_get_me_size (state) result (n)
integer :: n
class(state_matrix_t), intent(in) :: state
if (allocated (state%me)) then
n = size (state%me)
else
n = 0
end if
end function state_matrix_get_me_size
@ %def state_matrix_get_me_size
@
<<State matrices: state matrix: TBP>>=
procedure :: compute_n_sub => state_matrix_compute_n_sub
<<State matrices: sub interfaces>>=
module function state_matrix_compute_n_sub (state) result (n_sub)
integer :: n_sub
class(state_matrix_t), intent(in) :: state
end function state_matrix_compute_n_sub
<<State matrices: procedures>>=
module function state_matrix_compute_n_sub (state) result (n_sub)
integer :: n_sub
class(state_matrix_t), intent(in) :: state
type(state_iterator_t) :: it
type(quantum_numbers_t), dimension(state%depth) :: qn
integer :: sub, sub_pos
n_sub = 0
call it%init (state)
do while (it%is_valid ())
qn = it%get_quantum_numbers ()
sub = 0
sub_pos = qn_array_sub_pos ()
if (sub_pos > 0) sub = qn(sub_pos)%get_sub ()
if (sub > n_sub) n_sub = sub
call it%advance ()
end do
contains
function qn_array_sub_pos () result (pos)
integer :: pos
integer :: i
pos = 0
do i = 1, state%depth
if (qn(i)%get_sub () > 0) then
pos = i
exit
end if
end do
end function qn_array_sub_pos
end function state_matrix_compute_n_sub
@ %def state_matrix_compute_n_sub
@
<<State matrices: state matrix: TBP>>=
procedure :: set_n_sub => state_matrix_set_n_sub
<<State matrices: sub interfaces>>=
module subroutine state_matrix_set_n_sub (state)
class(state_matrix_t), intent(inout) :: state
end subroutine state_matrix_set_n_sub
<<State matrices: procedures>>=
module subroutine state_matrix_set_n_sub (state)
class(state_matrix_t), intent(inout) :: state
state%n_sub = state%compute_n_sub ()
end subroutine state_matrix_set_n_sub
@ %def state_matrix_set_n_sub
@ Return number of subtractions.
<<State matrices: state matrix: TBP>>=
procedure :: get_n_sub => state_matrix_get_n_sub
<<State matrices: sub interfaces>>=
module function state_matrix_get_n_sub (state) result (n_sub)
integer :: n_sub
class(state_matrix_t), intent(in) :: state
end function state_matrix_get_n_sub
<<State matrices: procedures>>=
module function state_matrix_get_n_sub (state) result (n_sub)
integer :: n_sub
class(state_matrix_t), intent(in) :: state
if (state%n_sub < 0) then
call msg_bug ("[state_matrix_get_n_sub] number of subtractions not set.")
end if
n_sub = state%n_sub
end function state_matrix_get_n_sub
@ %def state_matrix_get_n_sub
@ Return the number of leaves. This can be larger than the number of
independent matrix elements.
<<State matrices: state matrix: TBP>>=
procedure :: get_n_leaves => state_matrix_get_n_leaves
<<State matrices: sub interfaces>>=
module function state_matrix_get_n_leaves (state) result (n)
integer :: n
class(state_matrix_t), intent(in) :: state
type(state_iterator_t) :: it
end function state_matrix_get_n_leaves
<<State matrices: procedures>>=
module function state_matrix_get_n_leaves (state) result (n)
integer :: n
class(state_matrix_t), intent(in) :: state
type(state_iterator_t) :: it
n = 0
call it%init (state)
do while (it%is_valid ())
n = n + 1
call it%advance ()
end do
end function state_matrix_get_n_leaves
@ %def state_matrix_get_n_leaves
@ Return the depth:
<<State matrices: state matrix: TBP>>=
procedure :: get_depth => state_matrix_get_depth
<<State matrices: sub interfaces>>=
pure module function state_matrix_get_depth (state) result (depth)
integer :: depth
class(state_matrix_t), intent(in) :: state
end function state_matrix_get_depth
<<State matrices: procedures>>=
pure module function state_matrix_get_depth (state) result (depth)
integer :: depth
class(state_matrix_t), intent(in) :: state
depth = state%depth
end function state_matrix_get_depth
@ %def state_matrix_get_depth
@ Return the norm:
<<State matrices: state matrix: TBP>>=
procedure :: get_norm => state_matrix_get_norm
<<State matrices: sub interfaces>>=
pure module function state_matrix_get_norm (state) result (norm)
real(default) :: norm
class(state_matrix_t), intent(in) :: state
end function state_matrix_get_norm
<<State matrices: procedures>>=
pure module function state_matrix_get_norm (state) result (norm)
real(default) :: norm
class(state_matrix_t), intent(in) :: state
norm = state%norm
end function state_matrix_get_norm
@ %def state_matrix_get_norm
@
\subsubsection{Retrieving contents}
Return the quantum number array, using an index. We have to scan the
state matrix since there is no shortcut.
<<State matrices: state matrix: TBP>>=
procedure :: get_quantum_number => &
state_matrix_get_quantum_number
<<State matrices: sub interfaces>>=
module function state_matrix_get_quantum_number (state, i, by_me_index) result (qn)
class(state_matrix_t), intent(in), target :: state
integer, intent(in) :: i
logical, intent(in), optional :: by_me_index
type(quantum_numbers_t), dimension(state%depth) :: qn
end function state_matrix_get_quantum_number
<<State matrices: procedures>>=
module function state_matrix_get_quantum_number (state, i, by_me_index) result (qn)
class(state_matrix_t), intent(in), target :: state
integer, intent(in) :: i
logical, intent(in), optional :: by_me_index
logical :: opt_by_me_index
type(quantum_numbers_t), dimension(state%depth) :: qn
type(state_iterator_t) :: it
integer :: k
opt_by_me_index = .false.
if (present (by_me_index)) opt_by_me_index = by_me_index
k = 0
call it%init (state)
do while (it%is_valid ())
if (opt_by_me_index) then
k = it%get_me_index ()
else
k = k + 1
end if
if (k == i) then
qn = it%get_quantum_numbers ()
exit
end if
call it%advance ()
end do
end function state_matrix_get_quantum_number
@ %def state_matrix_get_quantum_number
<<State matrices: state matrix: TBP>>=
generic :: get_quantum_numbers => get_quantum_numbers_all, get_quantum_numbers_mask
procedure :: get_quantum_numbers_all => state_matrix_get_quantum_numbers_all
procedure :: get_quantum_numbers_mask => state_matrix_get_quantum_numbers_mask
<<State matrices: sub interfaces>>=
module subroutine state_matrix_get_quantum_numbers_all (state, qn)
class(state_matrix_t), intent(in), target :: state
type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn
end subroutine state_matrix_get_quantum_numbers_all
<<State matrices: procedures>>=
module subroutine state_matrix_get_quantum_numbers_all (state, qn)
class(state_matrix_t), intent(in), target :: state
type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn
integer :: i
allocate (qn (state%get_n_matrix_elements (), &
state%get_depth()))
do i = 1, state%get_n_matrix_elements ()
qn (i, :) = state%get_quantum_number (i)
end do
end subroutine state_matrix_get_quantum_numbers_all
@ %def state_matrix_get_quantum_numbers_all
@
<<State matrices: sub interfaces>>=
module subroutine state_matrix_get_quantum_numbers_mask (state, qn_mask, qn)
class(state_matrix_t), intent(in), target :: state
type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask
type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn
end subroutine state_matrix_get_quantum_numbers_mask
<<State matrices: procedures>>=
module subroutine state_matrix_get_quantum_numbers_mask (state, qn_mask, qn)
class(state_matrix_t), intent(in), target :: state
type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask
type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn
type(quantum_numbers_t), dimension(:), allocatable :: qn_tmp
type(state_matrix_t) :: state_tmp
type(state_iterator_t) :: it
integer :: i, n
n = state%get_n_matrix_elements (qn_mask)
allocate (qn (n, state%get_depth ()))
allocate (qn_tmp (state%get_depth ()))
call it%init (state)
call state_tmp%init ()
do while (it%is_valid ())
qn_tmp = it%get_quantum_numbers ()
call qn_tmp%undefine (qn_mask)
call state_tmp%add_state (qn_tmp)
call it%advance ()
end do
do i = 1, n
qn (i, :) = state_tmp%get_quantum_number (i)
end do
call state_tmp%final ()
end subroutine state_matrix_get_quantum_numbers_mask
@ %def state_matrix_get_quantum_numbers_mask
@
<<State matrices: state matrix: TBP>>=
procedure :: get_flavors => state_matrix_get_flavors
<<State matrices: sub interfaces>>=
module subroutine state_matrix_get_flavors (state, only_elementary, qn_mask, flv)
class(state_matrix_t), intent(in), target :: state
logical, intent(in) :: only_elementary
type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask
integer, intent(out), dimension(:,:), allocatable :: flv
end subroutine state_matrix_get_flavors
<<State matrices: procedures>>=
module subroutine state_matrix_get_flavors (state, only_elementary, qn_mask, flv)
class(state_matrix_t), intent(in), target :: state
logical, intent(in) :: only_elementary
type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask
integer, intent(out), dimension(:,:), allocatable :: flv
type(quantum_numbers_t), dimension(:,:), allocatable :: qn
integer :: i_flv, n_partons
type(flavor_t), dimension(:), allocatable :: flv_flv
if (present (qn_mask)) then
call state%get_quantum_numbers (qn_mask, qn)
else
call state%get_quantum_numbers (qn)
end if
allocate (flv_flv (size (qn, dim=2)))
if (only_elementary) then
flv_flv = qn(1, :)%get_flavor ()
n_partons = count (is_elementary (flv_flv%get_pdg ()))
end if
allocate (flv (n_partons, size (qn, dim=1)))
associate (n_flv => size (qn, dim=1))
do i_flv = 1, size (qn, dim=1)
flv_flv = qn(i_flv, :)%get_flavor ()
flv(:, i_flv) = pack (flv_flv%get_pdg (), is_elementary(flv_flv%get_pdg()))
end do
end associate
contains
elemental function is_elementary (pdg)
logical :: is_elementary
integer, intent(in) :: pdg
is_elementary = abs(pdg) /= 2212 .and. abs(pdg) /= 92 .and. abs(pdg) /= 93
end function is_elementary
end subroutine state_matrix_get_flavors
@ %def state_matrix_get_flavors
@ Return a single matrix element using its index. Works only if the
shortcut array is allocated.
<<State matrices: state matrix: TBP>>=
generic :: get_matrix_element => get_matrix_element_single
generic :: get_matrix_element => get_matrix_element_array
procedure :: get_matrix_element_single => &
state_matrix_get_matrix_element_single
procedure :: get_matrix_element_array => &
state_matrix_get_matrix_element_array
<<State matrices: sub interfaces>>=
elemental module function state_matrix_get_matrix_element_single (state, i) result (me)
complex(default) :: me
class(state_matrix_t), intent(in) :: state
integer, intent(in) :: i
end function state_matrix_get_matrix_element_single
<<State matrices: procedures>>=
elemental module function state_matrix_get_matrix_element_single (state, i) result (me)
complex(default) :: me
class(state_matrix_t), intent(in) :: state
integer, intent(in) :: i
if (allocated (state%me)) then
me = state%me(i)
else
me = 0
end if
end function state_matrix_get_matrix_element_single
@ %def state_matrix_get_matrix_element_single
@
<<State matrices: sub interfaces>>=
module function state_matrix_get_matrix_element_array (state) result (me)
complex(default), dimension(:), allocatable :: me
class(state_matrix_t), intent(in) :: state
end function state_matrix_get_matrix_element_array
<<State matrices: procedures>>=
module function state_matrix_get_matrix_element_array (state) result (me)
complex(default), dimension(:), allocatable :: me
class(state_matrix_t), intent(in) :: state
if (allocated (state%me)) then
allocate (me (size (state%me)))
me = state%me
else
me = 0
end if
end function state_matrix_get_matrix_element_array
@ %def state_matrix_get_matrix_element_array
@ Return the color index with maximum absolute value that is present within
the state matrix.
<<State matrices: state matrix: TBP>>=
procedure :: get_max_color_value => state_matrix_get_max_color_value
<<State matrices: sub interfaces>>=
module function state_matrix_get_max_color_value (state) result (cmax)
integer :: cmax
class(state_matrix_t), intent(in) :: state
end function state_matrix_get_max_color_value
<<State matrices: procedures>>=
module function state_matrix_get_max_color_value (state) result (cmax)
integer :: cmax
class(state_matrix_t), intent(in) :: state
if (associated (state%root)) then
cmax = node_get_max_color_value (state%root)
else
cmax = 0
end if
contains
recursive function node_get_max_color_value (node) result (cmax)
integer :: cmax
type(node_t), intent(in), target :: node
type(node_t), pointer :: current
cmax = quantum_numbers_get_max_color_value (node%qn)
current => node%child_first
do while (associated (current))
cmax = max (cmax, node_get_max_color_value (current))
current => current%next
end do
end function node_get_max_color_value
end function state_matrix_get_max_color_value
@ %def state_matrix_get_max_color_value
@
\subsubsection{Building the quantum state}
The procedure generates a branch associated to the input array of
quantum numbers. If the branch exists already, it is used.
Optionally, we set the matrix-element index, a value (which may be
added to the previous one), and increment one of the possible
counters. We may also return the matrix element index of the current
node.
<<State matrices: state matrix: TBP>>=
procedure :: add_state => state_matrix_add_state
<<State matrices: sub interfaces>>=
module subroutine state_matrix_add_state (state, qn, index, value, &
sum_values, counter_index, ignore_sub_for_qn, me_index)
class(state_matrix_t), intent(inout) :: state
type(quantum_numbers_t), dimension(:), intent(in) :: qn
integer, intent(in), optional :: index
complex(default), intent(in), optional :: value
logical, intent(in), optional :: sum_values
integer, intent(in), optional :: counter_index
logical, intent(in), optional :: ignore_sub_for_qn
integer, intent(out), optional :: me_index
end subroutine state_matrix_add_state
<<State matrices: procedures>>=
module subroutine state_matrix_add_state (state, qn, index, value, &
sum_values, counter_index, ignore_sub_for_qn, me_index)
class(state_matrix_t), intent(inout) :: state
type(quantum_numbers_t), dimension(:), intent(in) :: qn
integer, intent(in), optional :: index
complex(default), intent(in), optional :: value
logical, intent(in), optional :: sum_values
integer, intent(in), optional :: counter_index
logical, intent(in), optional :: ignore_sub_for_qn
integer, intent(out), optional :: me_index
logical :: set_index, get_index, add
set_index = present (index)
get_index = present (me_index)
add = .false.; if (present (sum_values)) add = sum_values
if (state%depth == 0) then
state%depth = size (qn)
else if (state%depth /= size (qn)) then
call state%write ()
call msg_bug ("State matrix: depth mismatch")
end if
if (size (qn) > 0) call node_make_branch (state%root, qn)
contains
recursive subroutine node_make_branch (parent, qn)
type(node_t), pointer :: parent
type(quantum_numbers_t), dimension(:), intent(in) :: qn
type(node_t), pointer :: child
logical :: match
match = .false.
child => parent%child_first
SCAN_CHILDREN: do while (associated (child))
if (present (ignore_sub_for_qn)) then
if (ignore_sub_for_qn) then
match = quantum_numbers_eq_wo_sub (child%qn, qn(1))
else
match = child%qn == qn(1)
end if
else
match = child%qn == qn(1)
end if
if (match) exit SCAN_CHILDREN
child => child%next
end do SCAN_CHILDREN
if (.not. match) then
call node_append_child (parent, child)
child%qn = qn(1)
end if
select case (size (qn))
case (1)
if (.not. match) then
state%n_matrix_elements = state%n_matrix_elements + 1
child%me_index = state%n_matrix_elements
end if
if (set_index) then
child%me_index = index
end if
if (get_index) then
me_index = child%me_index
end if
if (present (counter_index)) then
if (.not. allocated (child%me_count)) then
allocate (child%me_count (state%n_counters))
child%me_count = 0
end if
child%me_count(counter_index) = child%me_count(counter_index) + 1
end if
if (present (value)) then
if (add) then
child%me = child%me + value
else
child%me = value
end if
end if
case (2:)
call node_make_branch (child, qn(2:))
end select
end subroutine node_make_branch
end subroutine state_matrix_add_state
@ %def state_matrix_add_state
@ Remove irrelevant flavor/color/helicity labels and the corresponding
branchings. The masks indicate which particles are affected; the
masks length should coincide with the depth of the trie (without the
root node). Recursively scan the whole tree, starting from the leaf
nodes and working up to the root node. If a mask entry is set for the
current tree level, scan the children there. For each child within
that level make a new empty branch where the masked quantum number is
undefined. Then recursively combine all following children with
matching quantum number into this new node and move on.
<<State matrices: state matrix: TBP>>=
procedure :: collapse => state_matrix_collapse
<<State matrices: sub interfaces>>=
module subroutine state_matrix_collapse (state, mask)
class(state_matrix_t), intent(inout) :: state
type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
end subroutine state_matrix_collapse
<<State matrices: procedures>>=
module subroutine state_matrix_collapse (state, mask)
class(state_matrix_t), intent(inout) :: state
type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
type(state_matrix_t) :: red_state
if (state%is_defined ()) then
call state%reduce (mask, red_state)
call state%final ()
state = red_state
end if
end subroutine state_matrix_collapse
@ %def state_matrix_collapse
@ Transform the given state matrix into a reduced state matrix where
some quantum numbers are removed, as indicated by the mask. The
procedure creates a new state matrix, so the old one can be deleted
after this if it is no longer used.
It is said that the matrix element ordering is lost afterwards. We allow to keep
the original matrix element index in the new state matrix. If the matrix
element indices are kept, we do not freeze the state matrix. After reordering
the matrix element indices by [[state_matrix_reorder_me]], the state matrix can
be frozen.
<<State matrices: state matrix: TBP>>=
procedure :: reduce => state_matrix_reduce
<<State matrices: sub interfaces>>=
module subroutine state_matrix_reduce (state, mask, red_state, keep_me_index)
class(state_matrix_t), intent(in), target :: state
type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
type(state_matrix_t), intent(out) :: red_state
logical, optional, intent(in) :: keep_me_index
end subroutine state_matrix_reduce
<<State matrices: procedures>>=
module subroutine state_matrix_reduce (state, mask, red_state, keep_me_index)
class(state_matrix_t), intent(in), target :: state
type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
type(state_matrix_t), intent(out) :: red_state
logical, optional, intent(in) :: keep_me_index
logical :: opt_keep_me_index
type(state_iterator_t) :: it
type(quantum_numbers_t), dimension(size(mask)) :: qn
opt_keep_me_index = .false.
if (present (keep_me_index)) opt_keep_me_index = keep_me_index
call red_state%init ()
call it%init (state)
do while (it%is_valid ())
qn = it%get_quantum_numbers ()
call qn%undefine (mask)
if (opt_keep_me_index) then
call red_state%add_state (qn, index = it%get_me_index ())
else
call red_state%add_state (qn)
end if
call it%advance ()
end do
if (.not. opt_keep_me_index) then
call red_state%freeze ()
end if
end subroutine state_matrix_reduce
@ %def state_matrix_reduce
@ Reorder the matrix elements -- not the tree itself. The procedure is necessary
in case the matrix element indices were kept when reducing over quantum numbers
and one wants to reintroduce the previous order of the matrix elements.
<<State matrices: state matrix: TBP>>=
procedure :: reorder_me => state_matrix_reorder_me
<<State matrices: sub interfaces>>=
module subroutine state_matrix_reorder_me (state, ordered_state)
class(state_matrix_t), intent(in), target :: state
type(state_matrix_t), intent(out) :: ordered_state
end subroutine state_matrix_reorder_me
<<State matrices: procedures>>=
module subroutine state_matrix_reorder_me (state, ordered_state)
class(state_matrix_t), intent(in), target :: state
type(state_matrix_t), intent(out) :: ordered_state
type(state_iterator_t) :: it
type(quantum_numbers_t), dimension(state%depth) :: qn
integer, dimension(:), allocatable :: me_index
integer :: i
call ordered_state%init ()
call get_me_index_sorted (state, me_index)
i = 1; call it%init (state)
do while (it%is_valid ())
qn = it%get_quantum_numbers ()
call ordered_state%add_state (qn, index = me_index(i))
i = i + 1; call it%advance ()
end do
call ordered_state%freeze ()
contains
subroutine get_me_index_sorted (state, me_index)
class(state_matrix_t), intent(in), target :: state
integer, dimension(:), allocatable, intent(out) :: me_index
type(state_iterator_t) :: it
integer :: i, j
integer, dimension(:), allocatable :: me_index_unsorted, me_index_sorted
associate (n_matrix_elements => state%get_n_matrix_elements ())
allocate (me_index(n_matrix_elements), source = 0)
allocate (me_index_sorted(n_matrix_elements), source = 0)
allocate (me_index_unsorted(n_matrix_elements), source = 0)
i = 1; call it%init (state)
do while (it%is_valid ())
me_index_unsorted(i) = it%get_me_index ()
i = i + 1
call it%advance ()
end do
me_index_sorted = sort (me_index_unsorted)
! We do not care about efficiency at this point.
UNSORTED: do i = 1, n_matrix_elements
SORTED: do j = 1, n_matrix_elements
if (me_index_unsorted(i) == me_index_sorted(j)) then
me_index(i) = j
cycle UNSORTED
end if
end do SORTED
end do UNSORTED
end associate
end subroutine get_me_index_sorted
end subroutine state_matrix_reorder_me
@ %def state_matrix_order_by_flavors
@ Sets all matrix elements whose flavor structure is a duplicate
of another flavor structure to zero. We need this for the real finite to
ignore duplicate flavor structures while keeping the indices identical to the
singular real component.
When comparing the flavor structures, we take into account permutations of final-
state particles. To do this properly, we keep only the non-hard flavors and the
initial-state flavors, i.e. the first two hard flavors fixed.
<<State matrices: state matrix: TBP>>=
procedure :: set_duplicate_flv_zero => state_matrix_set_duplicate_flv_zero
<<State matrices: sub interfaces>>=
module subroutine state_matrix_set_duplicate_flv_zero (state)
class(state_matrix_t), intent(inout), target :: state
end subroutine state_matrix_set_duplicate_flv_zero
<<State matrices: procedures>>=
module subroutine state_matrix_set_duplicate_flv_zero (state)
class(state_matrix_t), intent(inout), target :: state
type(quantum_numbers_t), dimension(state%depth) :: qn
type(flavor_t) :: flv
type(state_flv_content_t), allocatable :: state_flv
logical, dimension(:), allocatable :: hard_mask, sort_mask, duplicate_mask
integer :: i, j, n_in, n_flvs
n_flvs = state%get_depth ()
n_in = 2
!!! TODO (PS-28-07-21) n_in should not be hard coded to work for decays
!!! This assumes that the positions of the non-hard flavors are the same for all flavor structures.
qn = state%get_quantum_number(1)
allocate (hard_mask(n_flvs))
do i = 1, n_flvs
flv = qn(i)%get_flavor()
hard_mask(i) = flv%is_hard_process ()
end do
allocate (sort_mask(n_flvs))
sort_mask = hard_mask
j = 0
do i = 1, n_flvs
if (j == n_in) exit
if (sort_mask(i)) then
sort_mask(i) = .false.
j = j + 1
end if
end do
allocate (state_flv)
call state_flv%fill (state, sort_mask)
call state_flv%find_duplicates (duplicate_mask)
do i = 1, state%get_n_matrix_elements ()
if (duplicate_mask(i)) then
call state%set_matrix_element_single(i, cmplx(zero, zero, default))
end if
end do
end subroutine state_matrix_set_duplicate_flv_zero
@ %def state_matrix_set_duplicate_flv_zero
@ This subroutine sets up the matrix-element array. The leaf nodes
aquire the index values that point to the appropriate matrix-element
entry.
We recursively scan the trie. Once we arrive at a leaf node, the
index is increased and associated to that node. Finally, we allocate
the matrix-element array with the appropriate size.
If matrix element values are temporarily stored within the leaf nodes,
we scan the state again and transfer them to the matrix-element array.
<<State matrices: state matrix: TBP>>=
procedure :: freeze => state_matrix_freeze
<<State matrices: sub interfaces>>=
module subroutine state_matrix_freeze (state)
class(state_matrix_t), intent(inout), target :: state
end subroutine state_matrix_freeze
<<State matrices: procedures>>=
module subroutine state_matrix_freeze (state)
class(state_matrix_t), intent(inout), target :: state
type(state_iterator_t) :: it
if (associated (state%root)) then
if (allocated (state%me)) deallocate (state%me)
allocate (state%me (state%n_matrix_elements))
state%me = 0
call state%set_n_sub ()
end if
if (state%leaf_nodes_store_values) then
call it%init (state)
do while (it%is_valid ())
state%me(it%get_me_index ()) = it%get_matrix_element ()
call it%advance ()
end do
state%leaf_nodes_store_values = .false.
end if
end subroutine state_matrix_freeze
@ %def state_matrix_freeze
@
\subsubsection{Direct access to the value array}
Several methods for setting a value directly are summarized in this
generic:
<<State matrices: state matrix: TBP>>=
generic :: set_matrix_element => set_matrix_element_qn
generic :: set_matrix_element => set_matrix_element_all
generic :: set_matrix_element => set_matrix_element_array
generic :: set_matrix_element => set_matrix_element_single
generic :: set_matrix_element => set_matrix_element_clone
procedure :: set_matrix_element_qn => state_matrix_set_matrix_element_qn
procedure :: set_matrix_element_all => state_matrix_set_matrix_element_all
procedure :: set_matrix_element_array => &
state_matrix_set_matrix_element_array
procedure :: set_matrix_element_single => &
state_matrix_set_matrix_element_single
procedure :: set_matrix_element_clone => &
state_matrix_set_matrix_element_clone
@ %def state_matrix_set_matrix_element
@ Set a value that corresponds to a quantum number array:
<<State matrices: sub interfaces>>=
module subroutine state_matrix_set_matrix_element_qn (state, qn, value)
class(state_matrix_t), intent(inout), target :: state
type(quantum_numbers_t), dimension(:), intent(in) :: qn
complex(default), intent(in) :: value
end subroutine state_matrix_set_matrix_element_qn
<<State matrices: procedures>>=
module subroutine state_matrix_set_matrix_element_qn (state, qn, value)
class(state_matrix_t), intent(inout), target :: state
type(quantum_numbers_t), dimension(:), intent(in) :: qn
complex(default), intent(in) :: value
type(state_iterator_t) :: it
if (.not. allocated (state%me)) then
allocate (state%me (size(qn)))
end if
call it%init (state)
call it%go_to_qn (qn)
call it%set_matrix_element (value)
end subroutine state_matrix_set_matrix_element_qn
@ %def state_matrix_set_matrix_element_qn
@ Set all matrix elements to a single value
<<State matrices: sub interfaces>>=
module subroutine state_matrix_set_matrix_element_all (state, value)
class(state_matrix_t), intent(inout) :: state
complex(default), intent(in) :: value
end subroutine state_matrix_set_matrix_element_all
<<State matrices: procedures>>=
module subroutine state_matrix_set_matrix_element_all (state, value)
class(state_matrix_t), intent(inout) :: state
complex(default), intent(in) :: value
if (.not. allocated (state%me)) then
allocate (state%me (state%n_matrix_elements))
end if
state%me = value
end subroutine state_matrix_set_matrix_element_all
@ %def state_matrix_set_matrix_element_all
@ Set the matrix-element array directly.
<<State matrices: sub interfaces>>=
module subroutine state_matrix_set_matrix_element_array (state, value, range)
class(state_matrix_t), intent(inout) :: state
complex(default), intent(in), dimension(:) :: value
integer, intent(in), dimension(:), optional :: range
end subroutine state_matrix_set_matrix_element_array
<<State matrices: procedures>>=
module subroutine state_matrix_set_matrix_element_array (state, value, range)
class(state_matrix_t), intent(inout) :: state
complex(default), intent(in), dimension(:) :: value
integer, intent(in), dimension(:), optional :: range
if (present (range)) then
state%me(range) = value
else
if (.not. allocated (state%me)) &
allocate (state%me (size (value)))
state%me(:) = value
end if
end subroutine state_matrix_set_matrix_element_array
@ %def state_matrix_set_matrix_element_array
@ Set a matrix element at position [[i]] to [[value]].
<<State matrices: sub interfaces>>=
pure module subroutine state_matrix_set_matrix_element_single (state, i, value)
class(state_matrix_t), intent(inout) :: state
integer, intent(in) :: i
complex(default), intent(in) :: value
end subroutine state_matrix_set_matrix_element_single
<<State matrices: procedures>>=
pure module subroutine state_matrix_set_matrix_element_single (state, i, value)
class(state_matrix_t), intent(inout) :: state
integer, intent(in) :: i
complex(default), intent(in) :: value
if (.not. allocated (state%me)) then
allocate (state%me (state%n_matrix_elements))
end if
state%me(i) = value
end subroutine state_matrix_set_matrix_element_single
@ %def state_matrix_set_matrix_element_single
@ Clone the matrix elements from another (matching) state matrix.
<<State matrices: sub interfaces>>=
module subroutine state_matrix_set_matrix_element_clone (state, state1)
class(state_matrix_t), intent(inout) :: state
type(state_matrix_t), intent(in) :: state1
end subroutine state_matrix_set_matrix_element_clone
<<State matrices: procedures>>=
module subroutine state_matrix_set_matrix_element_clone (state, state1)
class(state_matrix_t), intent(inout) :: state
type(state_matrix_t), intent(in) :: state1
if (.not. allocated (state1%me)) return
if (.not. allocated (state%me)) allocate (state%me (size (state1%me)))
state%me = state1%me
end subroutine state_matrix_set_matrix_element_clone
@ %def state_matrix_set_matrix_element_clone
@ Add a value to a matrix element
<<State matrices: state matrix: TBP>>=
procedure :: add_to_matrix_element => state_matrix_add_to_matrix_element
<<State matrices: sub interfaces>>=
module subroutine state_matrix_add_to_matrix_element (state, qn, value, match_only_flavor)
class(state_matrix_t), intent(inout), target :: state
type(quantum_numbers_t), dimension(:), intent(in) :: qn
complex(default), intent(in) :: value
logical, intent(in), optional :: match_only_flavor
end subroutine state_matrix_add_to_matrix_element
<<State matrices: procedures>>=
module subroutine state_matrix_add_to_matrix_element (state, qn, value, match_only_flavor)
class(state_matrix_t), intent(inout), target :: state
type(quantum_numbers_t), dimension(:), intent(in) :: qn
complex(default), intent(in) :: value
logical, intent(in), optional :: match_only_flavor
type(state_iterator_t) :: it
call it%init (state)
call it%go_to_qn (qn, match_only_flavor)
if (it%is_valid ()) then
call it%add_to_matrix_element (value)
else
call msg_fatal ("Cannot add to matrix element - it%node not allocated")
end if
end subroutine state_matrix_add_to_matrix_element
@ %def state_matrix_add_to_matrix_element
@
\subsection{State iterators}
Accessing the quantum state from outside is best done using a
specialized iterator, i.e., a pointer to a particular branch of the
quantum state trie. Technically, the iterator contains a pointer to a
leaf node, but via parent pointers it allows to access the whole
branch where the leaf is attached. For quick access, we also keep the
branch depth (which is assumed to be universal for a quantum state).
<<State matrices: public>>=
public :: state_iterator_t
<<State matrices: types>>=
type :: state_iterator_t
private
integer :: depth = 0
type(state_matrix_t), pointer :: state => null ()
type(node_t), pointer :: node => null ()
contains
<<State matrices: state iterator: TBP>>
end type state_iterator_t
@ %def state_iterator
@ The initializer: Point at the first branch. Note that this cannot
be pure, thus not be elemental, because the iterator can be used to
manipulate data in the state matrix.
<<State matrices: state iterator: TBP>>=
procedure :: init => state_iterator_init
<<State matrices: sub interfaces>>=
module subroutine state_iterator_init (it, state)
class(state_iterator_t), intent(out) :: it
type(state_matrix_t), intent(in), target :: state
end subroutine state_iterator_init
<<State matrices: procedures>>=
module subroutine state_iterator_init (it, state)
class(state_iterator_t), intent(out) :: it
type(state_matrix_t), intent(in), target :: state
it%state => state
it%depth = state%depth
if (state%is_defined ()) then
it%node => state%root
do while (associated (it%node%child_first))
it%node => it%node%child_first
end do
else
it%node => null ()
end if
end subroutine state_iterator_init
@ %def state_iterator_init
@ Go forward. Recursively programmed: if the next node does not
exist, go back to the parent node and look at its successor (if
present), etc.
There is a possible pitfall in the implementation: If the dummy
pointer argument to the [[find_next]] routine is used directly, we
still get the correct result for the iterator, but calling the
recursion on [[node%parent]] means that we manipulate a parent pointer
in the original state in addition to the iterator. Making a local
copy of the pointer avoids this. Using pointer intent would be
helpful, but we do not yet rely on this F2003 feature.
<<State matrices: state iterator: TBP>>=
procedure :: advance => state_iterator_advance
<<State matrices: sub interfaces>>=
module subroutine state_iterator_advance (it)
class(state_iterator_t), intent(inout) :: it
end subroutine state_iterator_advance
<<State matrices: procedures>>=
module subroutine state_iterator_advance (it)
class(state_iterator_t), intent(inout) :: it
call find_next (it%node)
contains
recursive subroutine find_next (node_in)
type(node_t), intent(in), target :: node_in
type(node_t), pointer :: node
node => node_in
if (associated (node%next)) then
node => node%next
do while (associated (node%child_first))
node => node%child_first
end do
it%node => node
else if (associated (node%parent)) then
call find_next (node%parent)
else
it%node => null ()
end if
end subroutine find_next
end subroutine state_iterator_advance
@ %def state_iterator_advance
@ If all has been scanned, the iterator is at an undefined state.
Check for this:
<<State matrices: state iterator: TBP>>=
procedure :: is_valid => state_iterator_is_valid
<<State matrices: sub interfaces>>=
module function state_iterator_is_valid (it) result (defined)
logical :: defined
class(state_iterator_t), intent(in) :: it
end function state_iterator_is_valid
<<State matrices: procedures>>=
module function state_iterator_is_valid (it) result (defined)
logical :: defined
class(state_iterator_t), intent(in) :: it
defined = associated (it%node)
end function state_iterator_is_valid
@ %def state_iterator_is_valid
@ Return the matrix-element index that corresponds to the current node
<<State matrices: state iterator: TBP>>=
procedure :: get_me_index => state_iterator_get_me_index
<<State matrices: sub interfaces>>=
module function state_iterator_get_me_index (it) result (n)
integer :: n
class(state_iterator_t), intent(in) :: it
end function state_iterator_get_me_index
<<State matrices: procedures>>=
module function state_iterator_get_me_index (it) result (n)
integer :: n
class(state_iterator_t), intent(in) :: it
n = it%node%me_index
end function state_iterator_get_me_index
@ %def state_iterator_get_me_index
@ Return the number of times this quantum-number state has been added
(noting that it is physically inserted only the first time). Note
that for each state, there is an array of counters.
<<State matrices: state iterator: TBP>>=
procedure :: get_me_count => state_iterator_get_me_count
<<State matrices: sub interfaces>>=
module function state_iterator_get_me_count (it) result (n)
integer, dimension(:), allocatable :: n
class(state_iterator_t), intent(in) :: it
end function state_iterator_get_me_count
<<State matrices: procedures>>=
module function state_iterator_get_me_count (it) result (n)
integer, dimension(:), allocatable :: n
class(state_iterator_t), intent(in) :: it
if (allocated (it%node%me_count)) then
allocate (n (size (it%node%me_count)))
n = it%node%me_count
else
allocate (n (0))
end if
end function state_iterator_get_me_count
@ %def state_iterator_get_me_count
@
<<State matrices: state iterator: TBP>>=
procedure :: get_depth => state_iterator_get_depth
<<State matrices: sub interfaces>>=
pure module function state_iterator_get_depth (state_iterator) result (depth)
integer :: depth
class(state_iterator_t), intent(in) :: state_iterator
end function state_iterator_get_depth
<<State matrices: procedures>>=
pure module function state_iterator_get_depth (state_iterator) result (depth)
integer :: depth
class(state_iterator_t), intent(in) :: state_iterator
depth = state_iterator%depth
end function state_iterator_get_depth
@ %def state_iterator_get_depth
@ Proceed to the state associated with the quantum numbers [[qn]].
<<State matrices: state iterator: TBP>>=
procedure :: go_to_qn => state_iterator_go_to_qn
<<State matrices: sub interfaces>>=
module subroutine state_iterator_go_to_qn (it, qn, match_only_flavor)
class(state_iterator_t), intent(inout) :: it
type(quantum_numbers_t), dimension(:), intent(in) :: qn
logical, intent(in), optional :: match_only_flavor
end subroutine state_iterator_go_to_qn
<<State matrices: procedures>>=
module subroutine state_iterator_go_to_qn (it, qn, match_only_flavor)
class(state_iterator_t), intent(inout) :: it
type(quantum_numbers_t), dimension(:), intent(in) :: qn
logical, intent(in), optional :: match_only_flavor
type(quantum_numbers_t), dimension(:), allocatable :: qn_hard, qn_tmp
logical :: match_flv
match_flv = .false.; if (present (match_only_flavor)) match_flv = .true.
do while (it%is_valid ())
if (match_flv) then
qn_tmp = it%get_quantum_numbers ()
qn_hard = pack (qn_tmp, qn_tmp%are_hard_process ())
if (all (qn .fmatch. qn_hard)) then
return
else
call it%advance ()
end if
else
if (all (qn == it%get_quantum_numbers ())) then
return
else
call it%advance ()
end if
end if
end do
end subroutine state_iterator_go_to_qn
@ %def state_iterator_go_to_qn
@ Use the iterator to retrieve quantum-number information:
<<State matrices: state iterator: TBP>>=
generic :: get_quantum_numbers => get_qn_multi, get_qn_slice, &
get_qn_range, get_qn_single
generic :: get_flavor => get_flv_multi, get_flv_slice, &
get_flv_range, get_flv_single
generic :: get_color => get_col_multi, get_col_slice, &
get_col_range, get_col_single
generic :: get_helicity => get_hel_multi, get_hel_slice, &
get_hel_range, get_hel_single
<<State matrices: state iterator: TBP>>=
procedure :: get_qn_multi => state_iterator_get_qn_multi
procedure :: get_qn_slice => state_iterator_get_qn_slice
procedure :: get_qn_range => state_iterator_get_qn_range
procedure :: get_qn_single => state_iterator_get_qn_single
procedure :: get_flv_multi => state_iterator_get_flv_multi
procedure :: get_flv_slice => state_iterator_get_flv_slice
procedure :: get_flv_range => state_iterator_get_flv_range
procedure :: get_flv_single => state_iterator_get_flv_single
procedure :: get_col_multi => state_iterator_get_col_multi
procedure :: get_col_slice => state_iterator_get_col_slice
procedure :: get_col_range => state_iterator_get_col_range
procedure :: get_col_single => state_iterator_get_col_single
procedure :: get_hel_multi => state_iterator_get_hel_multi
procedure :: get_hel_slice => state_iterator_get_hel_slice
procedure :: get_hel_range => state_iterator_get_hel_range
procedure :: get_hel_single => state_iterator_get_hel_single
@ These versions return the whole quantum number array
<<State matrices: sub interfaces>>=
module function state_iterator_get_qn_multi (it) result (qn)
class(state_iterator_t), intent(in) :: it
type(quantum_numbers_t), dimension(it%depth) :: qn
end function state_iterator_get_qn_multi
module function state_iterator_get_flv_multi (it) result (flv)
class(state_iterator_t), intent(in) :: it
type(flavor_t), dimension(it%depth) :: flv
end function state_iterator_get_flv_multi
module function state_iterator_get_col_multi (it) result (col)
class(state_iterator_t), intent(in) :: it
type(color_t), dimension(it%depth) :: col
end function state_iterator_get_col_multi
module function state_iterator_get_hel_multi (it) result (hel)
class(state_iterator_t), intent(in) :: it
type(helicity_t), dimension(it%depth) :: hel
end function state_iterator_get_hel_multi
<<State matrices: procedures>>=
module function state_iterator_get_qn_multi (it) result (qn)
class(state_iterator_t), intent(in) :: it
type(quantum_numbers_t), dimension(it%depth) :: qn
type(node_t), pointer :: node
integer :: i
node => it%node
do i = it%depth, 1, -1
qn(i) = node%qn
node => node%parent
end do
end function state_iterator_get_qn_multi
module function state_iterator_get_flv_multi (it) result (flv)
class(state_iterator_t), intent(in) :: it
type(flavor_t), dimension(it%depth) :: flv
flv = quantum_numbers_get_flavor &
(it%get_quantum_numbers ())
end function state_iterator_get_flv_multi
module function state_iterator_get_col_multi (it) result (col)
class(state_iterator_t), intent(in) :: it
type(color_t), dimension(it%depth) :: col
col = quantum_numbers_get_color &
(it%get_quantum_numbers ())
end function state_iterator_get_col_multi
module function state_iterator_get_hel_multi (it) result (hel)
class(state_iterator_t), intent(in) :: it
type(helicity_t), dimension(it%depth) :: hel
hel = quantum_numbers_get_helicity &
(it%get_quantum_numbers ())
end function state_iterator_get_hel_multi
@ An array slice (derived from the above).
<<State matrices: sub interfaces>>=
module function state_iterator_get_qn_slice (it, index) result (qn)
class(state_iterator_t), intent(in) :: it
integer, dimension(:), intent(in) :: index
type(quantum_numbers_t), dimension(size(index)) :: qn
end function state_iterator_get_qn_slice
module function state_iterator_get_flv_slice (it, index) result (flv)
class(state_iterator_t), intent(in) :: it
integer, dimension(:), intent(in) :: index
type(flavor_t), dimension(size(index)) :: flv
end function state_iterator_get_flv_slice
module function state_iterator_get_col_slice (it, index) result (col)
class(state_iterator_t), intent(in) :: it
integer, dimension(:), intent(in) :: index
type(color_t), dimension(size(index)) :: col
end function state_iterator_get_col_slice
module function state_iterator_get_hel_slice (it, index) result (hel)
class(state_iterator_t), intent(in) :: it
integer, dimension(:), intent(in) :: index
type(helicity_t), dimension(size(index)) :: hel
end function state_iterator_get_hel_slice
<<State matrices: procedures>>=
module function state_iterator_get_qn_slice (it, index) result (qn)
class(state_iterator_t), intent(in) :: it
integer, dimension(:), intent(in) :: index
type(quantum_numbers_t), dimension(size(index)) :: qn
type(quantum_numbers_t), dimension(it%depth) :: qn_tmp
qn_tmp = state_iterator_get_qn_multi (it)
qn = qn_tmp(index)
end function state_iterator_get_qn_slice
module function state_iterator_get_flv_slice (it, index) result (flv)
class(state_iterator_t), intent(in) :: it
integer, dimension(:), intent(in) :: index
type(flavor_t), dimension(size(index)) :: flv
flv = quantum_numbers_get_flavor &
(it%get_quantum_numbers (index))
end function state_iterator_get_flv_slice
module function state_iterator_get_col_slice (it, index) result (col)
class(state_iterator_t), intent(in) :: it
integer, dimension(:), intent(in) :: index
type(color_t), dimension(size(index)) :: col
col = quantum_numbers_get_color &
(it%get_quantum_numbers (index))
end function state_iterator_get_col_slice
module function state_iterator_get_hel_slice (it, index) result (hel)
class(state_iterator_t), intent(in) :: it
integer, dimension(:), intent(in) :: index
type(helicity_t), dimension(size(index)) :: hel
hel = quantum_numbers_get_helicity &
(it%get_quantum_numbers (index))
end function state_iterator_get_hel_slice
@ An array range (implemented directly).
<<State matrices: sub interfaces>>=
module function state_iterator_get_qn_range (it, k1, k2) result (qn)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k1, k2
type(quantum_numbers_t), dimension(k2-k1+1) :: qn
end function state_iterator_get_qn_range
module function state_iterator_get_flv_range (it, k1, k2) result (flv)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k1, k2
type(flavor_t), dimension(k2-k1+1) :: flv
end function state_iterator_get_flv_range
module function state_iterator_get_col_range (it, k1, k2) result (col)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k1, k2
type(color_t), dimension(k2-k1+1) :: col
end function state_iterator_get_col_range
module function state_iterator_get_hel_range (it, k1, k2) result (hel)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k1, k2
type(helicity_t), dimension(k2-k1+1) :: hel
end function state_iterator_get_hel_range
<<State matrices: procedures>>=
module function state_iterator_get_qn_range (it, k1, k2) result (qn)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k1, k2
type(quantum_numbers_t), dimension(k2-k1+1) :: qn
type(node_t), pointer :: node
integer :: i
node => it%node
SCAN: do i = it%depth, 1, -1
if (k1 <= i .and. i <= k2) then
qn(i-k1+1) = node%qn
else
node => node%parent
end if
end do SCAN
end function state_iterator_get_qn_range
module function state_iterator_get_flv_range (it, k1, k2) result (flv)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k1, k2
type(flavor_t), dimension(k2-k1+1) :: flv
flv = quantum_numbers_get_flavor &
(it%get_quantum_numbers (k1, k2))
end function state_iterator_get_flv_range
module function state_iterator_get_col_range (it, k1, k2) result (col)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k1, k2
type(color_t), dimension(k2-k1+1) :: col
col = quantum_numbers_get_color &
(it%get_quantum_numbers (k1, k2))
end function state_iterator_get_col_range
module function state_iterator_get_hel_range (it, k1, k2) result (hel)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k1, k2
type(helicity_t), dimension(k2-k1+1) :: hel
hel = quantum_numbers_get_helicity &
(it%get_quantum_numbers (k1, k2))
end function state_iterator_get_hel_range
@ Just a specific single element
<<State matrices: sub interfaces>>=
module function state_iterator_get_qn_single (it, k) result (qn)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k
type(quantum_numbers_t) :: qn
end function state_iterator_get_qn_single
module function state_iterator_get_flv_single (it, k) result (flv)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k
type(flavor_t) :: flv
end function state_iterator_get_flv_single
module function state_iterator_get_col_single (it, k) result (col)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k
type(color_t) :: col
end function state_iterator_get_col_single
module function state_iterator_get_hel_single (it, k) result (hel)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k
type(helicity_t) :: hel
end function state_iterator_get_hel_single
<<State matrices: procedures>>=
module function state_iterator_get_qn_single (it, k) result (qn)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k
type(quantum_numbers_t) :: qn
type(node_t), pointer :: node
integer :: i
node => it%node
SCAN: do i = it%depth, 1, -1
if (i == k) then
qn = node%qn
exit SCAN
else
node => node%parent
end if
end do SCAN
end function state_iterator_get_qn_single
module function state_iterator_get_flv_single (it, k) result (flv)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k
type(flavor_t) :: flv
flv = quantum_numbers_get_flavor &
(it%get_quantum_numbers (k))
end function state_iterator_get_flv_single
module function state_iterator_get_col_single (it, k) result (col)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k
type(color_t) :: col
col = quantum_numbers_get_color &
(it%get_quantum_numbers (k))
end function state_iterator_get_col_single
module function state_iterator_get_hel_single (it, k) result (hel)
class(state_iterator_t), intent(in) :: it
integer, intent(in) :: k
type(helicity_t) :: hel
hel = quantum_numbers_get_helicity &
(it%get_quantum_numbers (k))
end function state_iterator_get_hel_single
@ %def state_iterator_get_quantum_numbers
@ %def state_iterator_get_flavor
@ %def state_iterator_get_color
@ %def state_iterator_get_helicity
@ Assign a model pointer to the current flavor entries.
<<State matrices: state iterator: TBP>>=
procedure :: set_model => state_iterator_set_model
<<State matrices: sub interfaces>>=
module subroutine state_iterator_set_model (it, model)
class(state_iterator_t), intent(inout) :: it
class(model_data_t), intent(in), target :: model
end subroutine state_iterator_set_model
<<State matrices: procedures>>=
module subroutine state_iterator_set_model (it, model)
class(state_iterator_t), intent(inout) :: it
class(model_data_t), intent(in), target :: model
type(node_t), pointer :: node
integer :: i
node => it%node
do i = it%depth, 1, -1
call node%qn%set_model (model)
node => node%parent
end do
end subroutine state_iterator_set_model
@ %def state_iterator_set_model
@ Modify the hard-interaction tag of the current flavor entries at a specific
position, in-place.
<<State matrices: state iterator: TBP>>=
procedure :: retag_hard_process => state_iterator_retag_hard_process
<<State matrices: sub interfaces>>=
module subroutine state_iterator_retag_hard_process (it, i, hard)
class(state_iterator_t), intent(inout) :: it
integer, intent(in) :: i
logical, intent(in) :: hard
end subroutine state_iterator_retag_hard_process
<<State matrices: procedures>>=
module subroutine state_iterator_retag_hard_process (it, i, hard)
class(state_iterator_t), intent(inout) :: it
integer, intent(in) :: i
logical, intent(in) :: hard
type(node_t), pointer :: node
integer :: j
node => it%node
do j = 1, it%depth-i
node => node%parent
end do
call node%qn%tag_hard_process (hard)
end subroutine state_iterator_retag_hard_process
@ %def state_iterator_retag_hard_process
@ Retrieve the matrix element value associated with the current node.
<<State matrices: state iterator: TBP>>=
procedure :: get_matrix_element => state_iterator_get_matrix_element
<<State matrices: sub interfaces>>=
module function state_iterator_get_matrix_element (it) result (me)
complex(default) :: me
class(state_iterator_t), intent(in) :: it
end function state_iterator_get_matrix_element
<<State matrices: procedures>>=
module function state_iterator_get_matrix_element (it) result (me)
complex(default) :: me
class(state_iterator_t), intent(in) :: it
if (it%state%leaf_nodes_store_values) then
me = it%node%me
else if (it%node%me_index /= 0) then
me = it%state%me(it%node%me_index)
else
me = 0
end if
end function state_iterator_get_matrix_element
@ %def state_iterator_get_matrix_element
@ Set the matrix element value using the state iterator.
<<State matrices: state iterator: TBP>>=
procedure :: set_matrix_element => state_iterator_set_matrix_element
<<State matrices: sub interfaces>>=
module subroutine state_iterator_set_matrix_element (it, value)
class(state_iterator_t), intent(inout) :: it
complex(default), intent(in) :: value
end subroutine state_iterator_set_matrix_element
<<State matrices: procedures>>=
module subroutine state_iterator_set_matrix_element (it, value)
class(state_iterator_t), intent(inout) :: it
complex(default), intent(in) :: value
if (it%node%me_index /= 0) it%state%me(it%node%me_index) = value
end subroutine state_iterator_set_matrix_element
@ %def state_iterator_set_matrix_element
@
<<State matrices: state iterator: TBP>>=
procedure :: add_to_matrix_element => state_iterator_add_to_matrix_element
<<State matrices: sub interfaces>>=
module subroutine state_iterator_add_to_matrix_element (it, value)
class(state_iterator_t), intent(inout) :: it
complex(default), intent(in) :: value
end subroutine state_iterator_add_to_matrix_element
<<State matrices: procedures>>=
module subroutine state_iterator_add_to_matrix_element (it, value)
class(state_iterator_t), intent(inout) :: it
complex(default), intent(in) :: value
if (it%node%me_index /= 0) &
it%state%me(it%node%me_index) = it%state%me(it%node%me_index) + value
end subroutine state_iterator_add_to_matrix_element
@ %def state_iterator_add_to_matrix_element
@
\subsection{Operations on quantum states}
Return a deep copy of a state matrix.
<<State matrices: public>>=
public :: assignment(=)
<<State matrices: interfaces>>=
interface assignment(=)
module procedure state_matrix_assign
end interface
<<State matrices: sub interfaces>>=
module subroutine state_matrix_assign (state_out, state_in)
type(state_matrix_t), intent(out) :: state_out
type(state_matrix_t), intent(in), target :: state_in
end subroutine state_matrix_assign
<<State matrices: procedures>>=
module subroutine state_matrix_assign (state_out, state_in)
type(state_matrix_t), intent(out) :: state_out
type(state_matrix_t), intent(in), target :: state_in
type(state_iterator_t) :: it
if (.not. state_in%is_defined ()) return
call state_out%init ()
call it%init (state_in)
do while (it%is_valid ())
call state_out%add_state (it%get_quantum_numbers (), &
it%get_me_index ())
call it%advance ()
end do
if (allocated (state_in%me)) then
allocate (state_out%me (size (state_in%me)))
state_out%me = state_in%me
end if
state_out%n_sub = state_in%n_sub
end subroutine state_matrix_assign
@ %def state_matrix_assign
@ Determine the indices of all diagonal matrix elements.
<<State matrices: state matrix: TBP>>=
procedure :: get_diagonal_entries => state_matrix_get_diagonal_entries
<<State matrices: sub interfaces>>=
module subroutine state_matrix_get_diagonal_entries (state, i)
class(state_matrix_t), intent(in) :: state
integer, dimension(:), allocatable, intent(out) :: i
end subroutine state_matrix_get_diagonal_entries
<<State matrices: procedures>>=
module subroutine state_matrix_get_diagonal_entries (state, i)
class(state_matrix_t), intent(in) :: state
integer, dimension(:), allocatable, intent(out) :: i
integer, dimension(state%n_matrix_elements) :: tmp
integer :: n
type(state_iterator_t) :: it
type(quantum_numbers_t), dimension(:), allocatable :: qn
n = 0
call it%init (state)
allocate (qn (it%depth))
do while (it%is_valid ())
qn = it%get_quantum_numbers ()
if (all (qn%are_diagonal ())) then
n = n + 1
tmp(n) = it%get_me_index ()
end if
call it%advance ()
end do
allocate (i(n))
if (n > 0) i = tmp(:n)
end subroutine state_matrix_get_diagonal_entries
@ %def state_matrices_get_diagonal_entries
@ Normalize all matrix elements, i.e., multiply by a common factor.
Assuming that the factor is nonzero, of course.
<<State matrices: state matrix: TBP>>=
procedure :: renormalize => state_matrix_renormalize
<<State matrices: sub interfaces>>=
module subroutine state_matrix_renormalize (state, factor)
class(state_matrix_t), intent(inout) :: state
complex(default), intent(in) :: factor
end subroutine state_matrix_renormalize
<<State matrices: procedures>>=
module subroutine state_matrix_renormalize (state, factor)
class(state_matrix_t), intent(inout) :: state
complex(default), intent(in) :: factor
state%me = state%me * factor
end subroutine state_matrix_renormalize
@ %def state_matrix_renormalize
@ Renormalize the state matrix by its trace, if nonzero. The renormalization
is reflected in the state-matrix norm.
<<State matrices: state matrix: TBP>>=
procedure :: normalize_by_trace => state_matrix_normalize_by_trace
<<State matrices: sub interfaces>>=
module subroutine state_matrix_normalize_by_trace (state)
class(state_matrix_t), intent(inout) :: state
end subroutine state_matrix_normalize_by_trace
<<State matrices: procedures>>=
module subroutine state_matrix_normalize_by_trace (state)
class(state_matrix_t), intent(inout) :: state
real(default) :: trace
trace = state%trace ()
if (trace /= 0) then
state%me = state%me / trace
state%norm = state%norm * trace
end if
end subroutine state_matrix_normalize_by_trace
@ %def state_matrix_renormalize_by_trace
@ Analogous, but renormalize by maximal (absolute) value.
<<State matrices: state matrix: TBP>>=
procedure :: normalize_by_max => state_matrix_normalize_by_max
<<State matrices: sub interfaces>>=
module subroutine state_matrix_normalize_by_max (state)
class(state_matrix_t), intent(inout) :: state
end subroutine state_matrix_normalize_by_max
<<State matrices: procedures>>=
module subroutine state_matrix_normalize_by_max (state)
class(state_matrix_t), intent(inout) :: state
real(default) :: m
m = maxval (abs (state%me))
if (m /= 0) then
state%me = state%me / m
state%norm = state%norm * m
end if
end subroutine state_matrix_normalize_by_max
@ %def state_matrix_renormalize_by_max
@ Explicitly set the norm of a state matrix.
<<State matrices: state matrix: TBP>>=
procedure :: set_norm => state_matrix_set_norm
<<State matrices: sub interfaces>>=
module subroutine state_matrix_set_norm (state, norm)
class(state_matrix_t), intent(inout) :: state
real(default), intent(in) :: norm
end subroutine state_matrix_set_norm
<<State matrices: procedures>>=
module subroutine state_matrix_set_norm (state, norm)
class(state_matrix_t), intent(inout) :: state
real(default), intent(in) :: norm
state%norm = norm
end subroutine state_matrix_set_norm
@ %def state_matrix_set_norm
@ Return the sum of all matrix element values.
<<State matrices: state matrix: TBP>>=
procedure :: sum => state_matrix_sum
<<State matrices: sub interfaces>>=
pure module function state_matrix_sum (state) result (value)
complex(default) :: value
class(state_matrix_t), intent(in) :: state
end function state_matrix_sum
<<State matrices: procedures>>=
pure module function state_matrix_sum (state) result (value)
complex(default) :: value
class(state_matrix_t), intent(in) :: state
value = sum (state%me)
end function state_matrix_sum
@ %def state_matrix_sum
@ Return the trace of a state matrix, i.e., the sum over all diagonal
values.
If [[qn_in]] is provided, only branches that match this
quantum-numbers array in flavor and helicity are considered. (This mode is
used for selecting a color state.)
<<State matrices: state matrix: TBP>>=
procedure :: trace => state_matrix_trace
<<State matrices: sub interfaces>>=
module function state_matrix_trace (state, qn_in) result (trace)
complex(default) :: trace
class(state_matrix_t), intent(in), target :: state
type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in
end function state_matrix_trace
<<State matrices: procedures>>=
module function state_matrix_trace (state, qn_in) result (trace)
complex(default) :: trace
class(state_matrix_t), intent(in), target :: state
type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in
type(quantum_numbers_t), dimension(:), allocatable :: qn
type(state_iterator_t) :: it
allocate (qn (state%get_depth ()))
trace = 0
call it%init (state)
do while (it%is_valid ())
qn = it%get_quantum_numbers ()
if (present (qn_in)) then
if (.not. all (qn .fhmatch. qn_in)) then
call it%advance (); cycle
end if
end if
if (all (qn%are_diagonal ())) then
trace = trace + it%get_matrix_element ()
end if
call it%advance ()
end do
end function state_matrix_trace
@ %def state_matrix_trace
@ Append new states which are color-contracted versions of the
existing states. The matrix element index of each color contraction
coincides with the index of its origin, so no new matrix elements are
generated. After this operation, no [[freeze]] must be performed
anymore.
<<State matrices: state matrix: TBP>>=
procedure :: add_color_contractions => state_matrix_add_color_contractions
<<State matrices: sub interfaces>>=
module subroutine state_matrix_add_color_contractions (state)
class(state_matrix_t), intent(inout), target :: state
end subroutine state_matrix_add_color_contractions
<<State matrices: procedures>>=
module subroutine state_matrix_add_color_contractions (state)
class(state_matrix_t), intent(inout), target :: state
type(state_iterator_t) :: it
type(quantum_numbers_t), dimension(:,:), allocatable :: qn
type(quantum_numbers_t), dimension(:,:), allocatable :: qn_con
integer, dimension(:), allocatable :: me_index
integer :: depth, n_me, i, j
depth = state%get_depth ()
n_me = state%get_n_matrix_elements ()
allocate (qn (depth, n_me))
allocate (me_index (n_me))
i = 0
call it%init (state)
do while (it%is_valid ())
i = i + 1
qn(:,i) = it%get_quantum_numbers ()
me_index(i) = it%get_me_index ()
call it%advance ()
end do
do i = 1, n_me
call quantum_number_array_make_color_contractions (qn(:,i), qn_con)
do j = 1, size (qn_con, 2)
call state%add_state (qn_con(:,j), index = me_index(i))
end do
end do
end subroutine state_matrix_add_color_contractions
@ %def state_matrix_add_color_contractions
@ This procedure merges two state matrices of equal depth. For each
quantum number (flavor, color, helicity), we take the entry from the
first argument where defined, otherwise the second one. (If both are
defined, we get an off-diagonal matrix.) The resulting
trie combines the information of the input tries in all possible ways.
Note that values are ignored, all values in the result are zero.
<<State matrices: public>>=
public :: merge_state_matrices
<<State matrices: sub interfaces>>=
module subroutine merge_state_matrices (state1, state2, state3)
type(state_matrix_t), intent(in), target :: state1, state2
type(state_matrix_t), intent(out) :: state3
end subroutine merge_state_matrices
<<State matrices: procedures>>=
module subroutine merge_state_matrices (state1, state2, state3)
type(state_matrix_t), intent(in), target :: state1, state2
type(state_matrix_t), intent(out) :: state3
type(state_iterator_t) :: it1, it2
type(quantum_numbers_t), dimension(state1%depth) :: qn1, qn2
if (state1%depth /= state2%depth) then
call state1%write ()
call state2%write ()
call msg_bug ("State matrices merge impossible: incompatible depths")
end if
call state3%init ()
call it1%init (state1)
do while (it1%is_valid ())
qn1 = it1%get_quantum_numbers ()
call it2%init (state2)
do while (it2%is_valid ())
qn2 = it2%get_quantum_numbers ()
call state3%add_state (qn1 .merge. qn2)
call it2%advance ()
end do
call it1%advance ()
end do
call state3%freeze ()
end subroutine merge_state_matrices
@ %def merge_state_matrices
@ Multiply matrix elements from two state matrices. Choose the elements
as given by the integer index arrays, multiply them and store the sum
of products in the indicated matrix element. The suffixes mean:
c=conjugate first factor; f=include weighting factor.
Note that the [[dot_product]] intrinsic function conjugates its first
complex argument. This is intended for the [[c]] suffix case, but
must be reverted for the plain-product case.
We provide analogous subroutines for just summing over state matrix
entries. The [[evaluate_sum]] variant includes the state-matrix norm
in the evaluation, the [[evaluate_me_sum]] takes into account just the
matrix elements proper.
<<State matrices: state matrix: TBP>>=
procedure :: evaluate_product => state_matrix_evaluate_product
procedure :: evaluate_product_cf => state_matrix_evaluate_product_cf
procedure :: evaluate_square_c => state_matrix_evaluate_square_c
procedure :: evaluate_sum => state_matrix_evaluate_sum
procedure :: evaluate_me_sum => state_matrix_evaluate_me_sum
<<State matrices: sub interfaces>>=
pure module subroutine state_matrix_evaluate_product &
(state, i, state1, state2, index1, index2)
class(state_matrix_t), intent(inout) :: state
integer, intent(in) :: i
type(state_matrix_t), intent(in) :: state1, state2
integer, dimension(:), intent(in) :: index1, index2
end subroutine state_matrix_evaluate_product
pure module subroutine state_matrix_evaluate_product_cf &
(state, i, state1, state2, index1, index2, factor)
class(state_matrix_t), intent(inout) :: state
integer, intent(in) :: i
type(state_matrix_t), intent(in) :: state1, state2
integer, dimension(:), intent(in) :: index1, index2
complex(default), dimension(:), intent(in) :: factor
end subroutine state_matrix_evaluate_product_cf
pure module subroutine state_matrix_evaluate_square_c (state, i, state1, index1)
class(state_matrix_t), intent(inout) :: state
integer, intent(in) :: i
type(state_matrix_t), intent(in) :: state1
integer, dimension(:), intent(in) :: index1
end subroutine state_matrix_evaluate_square_c
pure module subroutine state_matrix_evaluate_sum (state, i, state1, index1)
class(state_matrix_t), intent(inout) :: state
integer, intent(in) :: i
type(state_matrix_t), intent(in) :: state1
integer, dimension(:), intent(in) :: index1
end subroutine state_matrix_evaluate_sum
pure module subroutine state_matrix_evaluate_me_sum (state, i, state1, index1)
class(state_matrix_t), intent(inout) :: state
integer, intent(in) :: i
type(state_matrix_t), intent(in) :: state1
integer, dimension(:), intent(in) :: index1
end subroutine state_matrix_evaluate_me_sum
<<State matrices: procedures>>=
pure module subroutine state_matrix_evaluate_product &
(state, i, state1, state2, index1, index2)
class(state_matrix_t), intent(inout) :: state
integer, intent(in) :: i
type(state_matrix_t), intent(in) :: state1, state2
integer, dimension(:), intent(in) :: index1, index2
state%me(i) = &
dot_product (conjg (state1%me(index1)), state2%me(index2))
state%norm = state1%norm * state2%norm
end subroutine state_matrix_evaluate_product
pure module subroutine state_matrix_evaluate_product_cf &
(state, i, state1, state2, index1, index2, factor)
class(state_matrix_t), intent(inout) :: state
integer, intent(in) :: i
type(state_matrix_t), intent(in) :: state1, state2
integer, dimension(:), intent(in) :: index1, index2
complex(default), dimension(:), intent(in) :: factor
state%me(i) = &
dot_product (state1%me(index1), factor * state2%me(index2))
state%norm = state1%norm * state2%norm
end subroutine state_matrix_evaluate_product_cf
pure module subroutine state_matrix_evaluate_square_c (state, i, state1, index1)
class(state_matrix_t), intent(inout) :: state
integer, intent(in) :: i
type(state_matrix_t), intent(in) :: state1
integer, dimension(:), intent(in) :: index1
state%me(i) = &
dot_product (state1%me(index1), state1%me(index1))
state%norm = abs (state1%norm) ** 2
end subroutine state_matrix_evaluate_square_c
pure module subroutine state_matrix_evaluate_sum (state, i, state1, index1)
class(state_matrix_t), intent(inout) :: state
integer, intent(in) :: i
type(state_matrix_t), intent(in) :: state1
integer, dimension(:), intent(in) :: index1
state%me(i) = &
sum (state1%me(index1)) * state1%norm
end subroutine state_matrix_evaluate_sum
pure module subroutine state_matrix_evaluate_me_sum (state, i, state1, index1)
class(state_matrix_t), intent(inout) :: state
integer, intent(in) :: i
type(state_matrix_t), intent(in) :: state1
integer, dimension(:), intent(in) :: index1
state%me(i) = sum (state1%me(index1))
end subroutine state_matrix_evaluate_me_sum
@ %def state_matrix_evaluate_product
@ %def state_matrix_evaluate_product_cf
@ %def state_matrix_evaluate_square_c
@ %def state_matrix_evaluate_sum
@ %def state_matrix_evaluate_me_sum
@ Outer product (of states and matrix elements):
<<State matrices: public>>=
public :: outer_multiply
<<State matrices: interfaces>>=
interface outer_multiply
module procedure outer_multiply_pair
module procedure outer_multiply_array
end interface
@ %def outer_multiply
@ This procedure constructs the outer product of two state matrices.
<<State matrices: sub interfaces>>=
module subroutine outer_multiply_pair (state1, state2, state3)
type(state_matrix_t), intent(in), target :: state1, state2
type(state_matrix_t), intent(out) :: state3
end subroutine outer_multiply_pair
<<State matrices: procedures>>=
module subroutine outer_multiply_pair (state1, state2, state3)
type(state_matrix_t), intent(in), target :: state1, state2
type(state_matrix_t), intent(out) :: state3
type(state_iterator_t) :: it1, it2
type(quantum_numbers_t), dimension(state1%depth) :: qn1
type(quantum_numbers_t), dimension(state2%depth) :: qn2
type(quantum_numbers_t), dimension(state1%depth+state2%depth) :: qn3
complex(default) :: val1, val2
call state3%init (store_values = .true.)
call it1%init (state1)
do while (it1%is_valid ())
qn1 = it1%get_quantum_numbers ()
val1 = it1%get_matrix_element ()
call it2%init (state2)
do while (it2%is_valid ())
qn2 = it2%get_quantum_numbers ()
val2 = it2%get_matrix_element ()
qn3(:state1%depth) = qn1
qn3(state1%depth+1:) = qn2
call state3%add_state (qn3, value=val1 * val2)
call it2%advance ()
end do
call it1%advance ()
end do
call state3%freeze ()
end subroutine outer_multiply_pair
@ %def outer_multiply_state_pair
@ This executes the above routine iteratively for an arbitrary number
of state matrices.
<<State matrices: sub interfaces>>=
module subroutine outer_multiply_array (state_in, state_out)
type(state_matrix_t), dimension(:), intent(in), target :: state_in
type(state_matrix_t), intent(out) :: state_out
end subroutine outer_multiply_array
<<State matrices: procedures>>=
module subroutine outer_multiply_array (state_in, state_out)
type(state_matrix_t), dimension(:), intent(in), target :: state_in
type(state_matrix_t), intent(out) :: state_out
type(state_matrix_t), dimension(:), allocatable, target :: state_tmp
integer :: i, n
n = size (state_in)
select case (n)
case (0)
call state_out%init ()
case (1)
state_out = state_in(1)
case (2)
call outer_multiply_pair (state_in(1), state_in(2), state_out)
case default
allocate (state_tmp (n-2))
call outer_multiply_pair (state_in(1), state_in(2), state_tmp(1))
do i = 2, n - 2
call outer_multiply_pair (state_tmp(i-1), state_in(i+1), state_tmp(i))
end do
call outer_multiply_pair (state_tmp(n-2), state_in(n), state_out)
do i = 1, size(state_tmp)
call state_tmp(i)%final ()
end do
end select
end subroutine outer_multiply_array
@ %def outer_multiply_pair
@ %def outer_multiply_array
@
\subsection{Factorization}
In physical events, the state matrix is factorized into
single-particle state matrices. This is essentially a measurement.
In a simulation, we select one particular branch of the state matrix
with a probability that is determined by the matrix elements at the
leaves. (This makes sense only if the state matrix represents a
squared amplitude.) The selection is based on a (random) value [[x]]
between 0 and one that is provided as the third argument.
For flavor and color, we select a unique value for each particle. For
polarization, we have three options (modes). Option 1 is to drop
helicity information altogether and sum over all diagonal helicities.
Option 2 is to select a unique diagonal helicity in the same way as
flavor and color. Option 3 is, for each particle, to trace over all
remaining helicities in order to obtain an array of independent
single-particle helicity matrices.
Only branches that match the given quantum-number array [[qn_in]], if
present, are considered. For this array, color is ignored.
If the optional [[correlated_state]] is provided, it is assigned the
correlated density matrix for the selected flavor-color branch, so
multi-particle spin correlations remain available even if they are
dropped in the single-particle density matrices. This should be
done by the caller for the choice [[FM_CORRELATED_HELICITY]], which
otherwise is handled as [[FM_IGNORE_HELICITY]].
The algorithm is as follows: First, we determine the normalization by
summing over all diagonal matrix elements. In a second scan, we
select one of the diagonal matrix elements by a cumulative comparison
with the normalized random number. In the corresponding quantum
number array, we undefine the helicity entries. Then, we scan the
third time. For each branch that matches the selected quantum number
array (i.e., definite flavor and color, arbitrary helicity), we
determine its contribution to any of the single-particle state
matrices. The matrix-element value is added if all other quantum
numbers are diagonal, while the helicity of the chosen particle may be
arbitrary; this helicity determines the branch in the single-particle
state.
As a result, flavor and color quantum numbers are selected with the
correct probability. Within this subset of states, each
single-particle state matrix results from tracing over all other
particles. Note that the single-particle state matrices are not
normalized.
The flag [[ok]] is set to false if the matrix element sum is zero, so
factorization is not possible. This can happen if an event did not pass
cuts.
<<State matrices: parameters>>=
integer, parameter, public :: FM_IGNORE_HELICITY = 1
integer, parameter, public :: FM_SELECT_HELICITY = 2
integer, parameter, public :: FM_FACTOR_HELICITY = 3
integer, parameter, public :: FM_CORRELATED_HELICITY = 4
@ %def FM_IGNORE_HELICITY FM_SELECT_HELICITY FM_FACTOR_HELICITY
@ %def FM_CORRELATED_HELICITY
<<State matrices: state matrix: TBP>>=
procedure :: factorize => state_matrix_factorize
<<State matrices: sub interfaces>>=
module subroutine state_matrix_factorize &
(state, mode, x, ok, single_state, correlated_state, qn_in)
class(state_matrix_t), intent(in), target :: state
integer, intent(in) :: mode
real(default), intent(in) :: x
logical, intent(out) :: ok
type(state_matrix_t), &
dimension(:), allocatable, intent(out) :: single_state
type(state_matrix_t), intent(out), optional :: correlated_state
type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in
end subroutine state_matrix_factorize
<<State matrices: procedures>>=
module subroutine state_matrix_factorize &
(state, mode, x, ok, single_state, correlated_state, qn_in)
class(state_matrix_t), intent(in), target :: state
integer, intent(in) :: mode
real(default), intent(in) :: x
logical, intent(out) :: ok
type(state_matrix_t), &
dimension(:), allocatable, intent(out) :: single_state
type(state_matrix_t), intent(out), optional :: correlated_state
type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in
type(state_iterator_t) :: it
real(default) :: s, xt
complex(default) :: value
integer :: i, depth
type(quantum_numbers_t), dimension(:), allocatable :: qn, qn1
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
logical, dimension(:), allocatable :: diagonal
logical, dimension(:,:), allocatable :: mask
ok = .true.
if (x /= 0) then
xt = x * abs (state%trace (qn_in))
else
xt = 0
end if
s = 0
depth = state%get_depth ()
allocate (qn (depth), qn1 (depth), diagonal (depth))
call it%init (state)
do while (it%is_valid ())
qn = it%get_quantum_numbers ()
if (present (qn_in)) then
if (.not. all (qn .fhmatch. qn_in)) then
call it%advance (); cycle
end if
end if
if (all (qn%are_diagonal ())) then
value = abs (it%get_matrix_element ())
s = s + value
if (s > xt) exit
end if
call it%advance ()
end do
if (.not. it%is_valid ()) then
if (s == 0) ok = .false.
call it%init (state)
end if
allocate (single_state (depth))
do i = 1, depth
call single_state(i)%init (store_values = .true.)
end do
if (present (correlated_state)) &
call correlated_state%init (store_values = .true.)
qn = it%get_quantum_numbers ()
select case (mode)
case (FM_SELECT_HELICITY) ! single branch selected; shortcut
do i = 1, depth
call single_state(i)%add_state ([qn(i)], value=value)
end do
if (.not. present (correlated_state)) then
do i = 1, size(single_state)
call single_state(i)%freeze ()
end do
return
end if
end select
allocate (qn_mask (depth))
call qn_mask%init (.false., .false., .false., .true.)
call qn%undefine (qn_mask)
select case (mode)
case (FM_FACTOR_HELICITY)
allocate (mask (depth, depth))
mask = .false.
forall (i = 1:depth) mask(i,i) = .true.
end select
call it%init (state)
do while (it%is_valid ())
qn1 = it%get_quantum_numbers ()
if (all (qn .match. qn1)) then
diagonal = qn1%are_diagonal ()
value = it%get_matrix_element ()
select case (mode)
case (FM_IGNORE_HELICITY, FM_CORRELATED_HELICITY)
!!! trace over diagonal states that match qn
if (all (diagonal)) then
do i = 1, depth
call single_state(i)%add_state &
([qn(i)], value=value, sum_values=.true.)
end do
end if
case (FM_FACTOR_HELICITY) !!! trace over all other particles
do i = 1, depth
if (all (diagonal .or. mask(:,i))) then
call single_state(i)%add_state &
([qn1(i)], value=value, sum_values=.true.)
end if
end do
end select
if (present (correlated_state)) &
call correlated_state%add_state (qn1, value=value)
end if
call it%advance ()
end do
do i = 1, depth
call single_state(i)%freeze ()
end do
if (present (correlated_state)) &
call correlated_state%freeze ()
end subroutine state_matrix_factorize
@ %def state_matrix_factorize
@ \subsubsection{Auxiliary functions}
<<State matrices: state matrix: TBP>>=
procedure :: get_polarization_density_matrix &
=> state_matrix_get_polarization_density_matrix
<<State matrices: sub interfaces>>=
module function state_matrix_get_polarization_density_matrix &
(state) result (pol_matrix)
real(default), dimension(:,:), allocatable :: pol_matrix
class(state_matrix_t), intent(in) :: state
end function state_matrix_get_polarization_density_matrix
<<State matrices: procedures>>=
module function state_matrix_get_polarization_density_matrix &
(state) result (pol_matrix)
real(default), dimension(:,:), allocatable :: pol_matrix
class(state_matrix_t), intent(in) :: state
type(node_t), pointer :: current => null ()
!!! What's the generic way to allocate the matrix?
allocate (pol_matrix (4,4)); pol_matrix = 0
if (associated (state%root%child_first)) then
current => state%root%child_first
do while (associated (current))
call current%qn%write ()
current => current%next
end do
else
call msg_fatal ("Polarization state not allocated!")
end if
end function state_matrix_get_polarization_density_matrix
@ %def state_matrix_get_polarization_density_matrix
@
\subsubsection{Quantum-number matching}
This feature allows us to check whether a given string of PDG values
matches, in any ordering, any of the flavor combinations that the
state matrix provides. We will also request the permutation of the
successful match.
This type provides an account of the state's flavor content. We store
all flavor combinations, as [[pdg]] values, in an array, assuming that
the length is uniform.
We check only the entries selected by [[mask_match]]. Among those,
only the entries selected by [[mask_sort]] are sorted and thus matched
without respecting array element order. The entries that correspond to
a true value in the associated [[mask]] are sorted. The mapping from
the original state to the sorted state is given by the index array
[[map]].
<<State matrices: public>>=
public :: state_flv_content_t
<<State matrices: types>>=
type :: state_flv_content_t
private
integer, dimension(:,:), allocatable :: pdg
integer, dimension(:,:), allocatable :: map
logical, dimension(:), allocatable :: mask
contains
<<State matrices: state flv content: TBP>>
end type state_flv_content_t
@ %def state_matrix_flavor_content
@ Output (debugging aid).
<<State matrices: state flv content: TBP>>=
procedure :: write => state_flv_content_write
<<State matrices: sub interfaces>>=
module subroutine state_flv_content_write (state_flv, unit)
class(state_flv_content_t), intent(in), target :: state_flv
integer, intent(in), optional :: unit
end subroutine state_flv_content_write
<<State matrices: procedures>>=
module subroutine state_flv_content_write (state_flv, unit)
class(state_flv_content_t), intent(in), target :: state_flv
integer, intent(in), optional :: unit
integer :: u, n, d, i, j
u = given_output_unit (unit)
d = size (state_flv%pdg, 1)
n = size (state_flv%pdg, 2)
do i = 1, n
write (u, "(2x,'PDG =')", advance="no")
do j = 1, d
write (u, "(1x,I0)", advance="no") state_flv%pdg(j,i)
end do
write (u, "(' :: map = (')", advance="no")
do j = 1, d
write (u, "(1x,I0)", advance="no") state_flv%map(j,i)
end do
write (u, "(' )')")
end do
end subroutine state_flv_content_write
@ %def state_flv_content_write
@ Initialize with table length and mask. Each row of the [[map]]
array, of length $d$, is initialized with $(0,1,\ldots,d)$.
<<State matrices: state flv content: TBP>>=
procedure :: init => state_flv_content_init
<<State matrices: sub interfaces>>=
module subroutine state_flv_content_init (state_flv, n, mask)
class(state_flv_content_t), intent(out) :: state_flv
integer, intent(in) :: n
logical, dimension(:), intent(in) :: mask
end subroutine state_flv_content_init
<<State matrices: procedures>>=
module subroutine state_flv_content_init (state_flv, n, mask)
class(state_flv_content_t), intent(out) :: state_flv
integer, intent(in) :: n
logical, dimension(:), intent(in) :: mask
integer :: d, i
d = size (mask)
allocate (state_flv%pdg (d, n), source = 0)
allocate (state_flv%map (d, n), source = spread ([(i, i = 1, d)], 2, n))
allocate (state_flv%mask (d), source = mask)
end subroutine state_flv_content_init
@ %def state_flv_content_init
@ Manually fill the entries, one flavor set and mapping at a time.
<<State matrices: state flv content: TBP>>=
procedure :: set_entry => state_flv_content_set_entry
<<State matrices: sub interfaces>>=
module subroutine state_flv_content_set_entry (state_flv, i, pdg, map)
class(state_flv_content_t), intent(inout) :: state_flv
integer, intent(in) :: i
integer, dimension(:), intent(in) :: pdg, map
end subroutine state_flv_content_set_entry
<<State matrices: procedures>>=
module subroutine state_flv_content_set_entry (state_flv, i, pdg, map)
class(state_flv_content_t), intent(inout) :: state_flv
integer, intent(in) :: i
integer, dimension(:), intent(in) :: pdg, map
state_flv%pdg(:,i) = pdg
where (map /= 0)
state_flv%map(:,i) = map
end where
end subroutine state_flv_content_set_entry
@ %def state_flv_content_set_entry
@ Given a state matrix, determine the flavor content. That is, scan
the state matrix and extract flavor only, build a new state matrix
from that.
<<State matrices: state flv content: TBP>>=
procedure :: fill => state_flv_content_fill
<<State matrices: sub interfaces>>=
module subroutine state_flv_content_fill &
(state_flv, state_full, mask)
class(state_flv_content_t), intent(out) :: state_flv
type(state_matrix_t), intent(in), target :: state_full
logical, dimension(:), intent(in) :: mask
end subroutine state_flv_content_fill
<<State matrices: procedures>>=
module subroutine state_flv_content_fill &
(state_flv, state_full, mask)
class(state_flv_content_t), intent(out) :: state_flv
type(state_matrix_t), intent(in), target :: state_full
logical, dimension(:), intent(in) :: mask
type(state_matrix_t), target :: state_tmp
type(state_iterator_t) :: it
type(flavor_t), dimension(:), allocatable :: flv
integer, dimension(:), allocatable :: pdg, pdg_subset
integer, dimension(:), allocatable :: idx, map_subset, idx_subset, map
type(quantum_numbers_t), dimension(:), allocatable :: qn
integer :: n, d, c, i
call state_tmp%init ()
d = state_full%get_depth ()
allocate (flv (d), qn (d), pdg (d), idx (d), map (d))
idx = [(i, i = 1, d)]
c = count (mask)
allocate (pdg_subset (c), map_subset (c), idx_subset (c))
call it%init (state_full)
do while (it%is_valid ())
flv = it%get_flavor ()
call qn%init (flv)
call state_tmp%add_state (qn)
call it%advance ()
end do
n = state_tmp%get_n_leaves ()
call state_flv%init (n, mask)
i = 0
call it%init (state_tmp)
do while (it%is_valid ())
i = i + 1
flv = it%get_flavor ()
pdg = flv%get_pdg ()
idx_subset = pack (idx, mask)
pdg_subset = pack (pdg, mask)
map_subset = order_abs (pdg_subset)
map = unpack (idx_subset (map_subset), mask, idx)
call state_flv%set_entry (i, &
unpack (pdg_subset(map_subset), mask, pdg), &
order (map))
call it%advance ()
end do
call state_tmp%final ()
end subroutine state_flv_content_fill
@ %def state_flv_content_fill
@ Match a given flavor string against the flavor content. We sort the
input string and check whether it matches any of the stored strings.
If yes, return the mapping.
Only PDG entries under the preset mask are sorted before matching. The
other entries must match exactly (i.e., without reordering). A zero
entry matches anything. In any case, the length of the PDG string
must be equal to the length $d$ of the individual flavor-state entries.
<<State matrices: state flv content: TBP>>=
procedure :: match => state_flv_content_match
<<State matrices: sub interfaces>>=
module subroutine state_flv_content_match (state_flv, pdg, success, map)
class(state_flv_content_t), intent(in) :: state_flv
integer, dimension(:), intent(in) :: pdg
logical, intent(out) :: success
integer, dimension(:), intent(out) :: map
end subroutine state_flv_content_match
<<State matrices: procedures>>=
module subroutine state_flv_content_match (state_flv, pdg, success, map)
class(state_flv_content_t), intent(in) :: state_flv
integer, dimension(:), intent(in) :: pdg
logical, intent(out) :: success
integer, dimension(:), intent(out) :: map
integer, dimension(:), allocatable :: pdg_subset, pdg_sorted, map1, map2
integer, dimension(:), allocatable :: idx, map_subset, idx_subset
integer :: i, n, c, d
c = count (state_flv%mask)
d = size (state_flv%pdg, 1)
n = size (state_flv%pdg, 2)
allocate (idx (d), source = [(i, i = 1, d)])
allocate (idx_subset (c), pdg_subset (c), map_subset (c))
allocate (pdg_sorted (d), map1 (d), map2 (d))
idx_subset = pack (idx, state_flv%mask)
pdg_subset = pack (pdg, state_flv%mask)
map_subset = order_abs (pdg_subset)
pdg_sorted = unpack (pdg_subset(map_subset), state_flv%mask, pdg)
success = .false.
do i = 1, n
if (all (pdg_sorted == state_flv%pdg(:,i) &
.or. pdg_sorted == 0)) then
success = .true.
exit
end if
end do
if (success) then
map1 = state_flv%map(:,i)
map2 = unpack (idx_subset(map_subset), state_flv%mask, idx)
map = map2(map1)
where (pdg == 0) map = 0
end if
end subroutine state_flv_content_match
@ %def state_flv_content_match
@ Check if a given PDG code occurs anywhere in the table.
<<State matrices: state flv content: TBP>>=
procedure :: contains => state_flv_content_contains
<<State matrices: sub interfaces>>=
module function state_flv_content_contains (state_flv, pdg) result (success)
class(state_flv_content_t), intent(in) :: state_flv
integer, intent(in) :: pdg
logical :: success
end function state_flv_content_contains
<<State matrices: procedures>>=
module function state_flv_content_contains (state_flv, pdg) result (success)
class(state_flv_content_t), intent(in) :: state_flv
integer, intent(in) :: pdg
logical :: success
success = any (state_flv%pdg == pdg)
end function state_flv_content_contains
@ %def state_flv_content_contains
@
<<State matrices: procedures>>=
elemental function pacify_complex (c_in) result (c_pac)
complex(default), intent(in) :: c_in
complex(default) :: c_pac
c_pac = c_in
if (real(c_pac) == -real(c_pac)) then
c_pac = &
cmplx (0._default, aimag(c_pac), kind=default)
end if
if (aimag(c_pac) == -aimag(c_pac)) then
c_pac = &
cmplx (real(c_pac), 0._default, kind=default)
end if
end function pacify_complex
@ %def pacify_complex
@ Looks for flavor structures that only differ by a permutation
of the masked flavors.
The result is returned in form of a mask which is [[.true.]] at the
positions of a duplicate flavor structure from the second encounter on.
This routine implements the naive approach: We go through all flavor
structures and compare each one with each preceeding one. This works
but is $\mathcal{O}(n^2)$ in the number of flavor structures. Using
a table to remember which flavor structure has already been encountered,
if would be possible to find the duplicates in $\mathcal{O}(n)$.
<<State matrices: state flv content: TBP>>=
procedure :: find_duplicates => state_flv_content_find_duplicates
<<State matrices: sub interfaces>>=
module subroutine state_flv_content_find_duplicates (state_flv, duplicate_mask)
class(state_flv_content_t), intent(in) :: state_flv
logical, dimension(:), allocatable, intent(out) :: duplicate_mask
end subroutine state_flv_content_find_duplicates
<<State matrices: procedures>>=
module subroutine state_flv_content_find_duplicates (state_flv, duplicate_mask)
class(state_flv_content_t), intent(in) :: state_flv
logical, dimension(:), allocatable, intent(out) :: duplicate_mask
integer, dimension(:), allocatable :: flvst
integer :: i1, i2, n_flvsts
logical :: found_once
n_flvsts = size (state_flv%pdg, 2)
allocate (duplicate_mask (n_flvsts))
duplicate_mask = .false.
do i1 = 1, n_flvsts
found_once = .false.
flvst = state_flv%pdg(:,i1)
do i2 = 1, i1
if (all(flvst == state_flv%pdg(:,i2))) then
if (found_once) then
duplicate_mask(i1) = .true.
exit
else
found_once = .true.
end if
end if
end do
end do
end subroutine state_flv_content_find_duplicates
@ %def state_flv_content_find_duplicates
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[state_matrices_ut.f90]]>>=
<<File header>>
module state_matrices_ut
use unit_tests
use state_matrices_uti
<<Standard module head>>
<<State matrices: public test>>
contains
<<State matrices: test driver>>
end module state_matrices_ut
@ %def state_matrices_ut
@
<<[[state_matrices_uti.f90]]>>=
<<File header>>
module state_matrices_uti
<<Use kinds>>
use io_units
use format_defs, only: FMT_19
use flavors
use colors
use helicities
use quantum_numbers
use state_matrices
<<Standard module head>>
<<State matrices: test declarations>>
contains
<<State matrices: tests>>
end module state_matrices_uti
@ %def state_matrices_ut
@ API: driver for the unit tests below.
<<State matrices: public test>>=
public :: state_matrix_test
<<State matrices: test driver>>=
subroutine state_matrix_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<State matrices: execute tests>>
end subroutine state_matrix_test
@ %def state_matrix_test
@ Create two quantum states of equal depth and merge them.
<<State matrices: execute tests>>=
call test (state_matrix_1, "state_matrix_1", &
"check merge of quantum states of equal depth", &
u, results)
<<State matrices: test declarations>>=
public :: state_matrix_1
<<State matrices: tests>>=
subroutine state_matrix_1 (u)
integer, intent(in) :: u
type(state_matrix_t) :: state1, state2, state3
type(flavor_t), dimension(3) :: flv
type(color_t), dimension(3) :: col
type(quantum_numbers_t), dimension(3) :: qn
write (u, "(A)") "* Test output: state_matrix_1"
write (u, "(A)") "* Purpose: create and merge two quantum states"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
write (u, "(A)") "* State matrix 1"
write (u, "(A)")
call state1%init ()
call flv%init ([1, 2, 11])
call qn%init (flv, helicity ([ 1, 1, 1]))
call state1%add_state (qn)
call qn%init (flv, helicity ([ 1, 1, 1], [-1, 1, -1]))
call state1%add_state (qn)
call state1%freeze ()
call state1%write (u)
write (u, "(A)")
write (u, "(A)") "* State matrix 2"
write (u, "(A)")
call state2%init ()
call col(1)%init ([501])
call col(2)%init ([-501])
call col(3)%init ([0])
call qn%init (col, helicity ([-1, -1, 0]))
call state2%add_state (qn)
call col(3)%init ([99])
call qn%init (col, helicity ([-1, -1, 0]))
call state2%add_state (qn)
call state2%freeze ()
call state2%write (u)
write (u, "(A)")
write (u, "(A)") "* Merge the state matrices"
write (u, "(A)")
call merge_state_matrices (state1, state2, state3)
call state3%write (u)
write (u, "(A)")
write (u, "(A)") "* Collapse the state matrix"
write (u, "(A)")
call state3%collapse (quantum_numbers_mask (.false., .false., &
[.true.,.false.,.false.]))
call state3%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
write (u, "(A)")
call state1%final ()
call state2%final ()
call state3%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: state_matrix_1"
write (u, "(A)")
end subroutine state_matrix_1
@ %def state_matrix_1
@ Create a correlated three-particle state matrix and factorize it.
<<State matrices: execute tests>>=
call test (state_matrix_2, "state_matrix_2", &
"check factorizing 3-particle state matrix", &
u, results)
<<State matrices: test declarations>>=
public :: state_matrix_2
<<State matrices: tests>>=
subroutine state_matrix_2 (u)
integer, intent(in) :: u
type(state_matrix_t) :: state
type(state_matrix_t), dimension(:), allocatable :: single_state
type(state_matrix_t) :: correlated_state
integer :: f, h11, h12, h21, h22, i, mode
type(flavor_t), dimension(2) :: flv
type(color_t), dimension(2) :: col
type(helicity_t), dimension(2) :: hel
type(quantum_numbers_t), dimension(2) :: qn
logical :: ok
write (u, "(A)")
write (u, "(A)") "* Test output: state_matrix_2"
write (u, "(A)") "* Purpose: factorize correlated 3-particle state"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call state%init ()
do f = 1, 2
do h11 = -1, 1, 2
do h12 = -1, 1, 2
do h21 = -1, 1, 2
do h22 = -1, 1, 2
call flv%init ([f, -f])
call col(1)%init ([1])
call col(2)%init ([-1])
call hel%init ([h11,h12], [h21, h22])
call qn%init (flv, col, hel)
call state%add_state (qn)
end do
end do
end do
end do
end do
call state%freeze ()
call state%write (u)
write (u, "(A)")
write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") &
"* Trace = ", state%trace ()
write (u, "(A)")
do mode = 1, 3
write (u, "(A)")
write (u, "(A,I1)") "* Mode = ", mode
call state%factorize &
(mode, 0.15_default, ok, single_state, correlated_state)
do i = 1, size (single_state)
write (u, "(A)")
call single_state(i)%write (u)
write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") &
"Trace = ", single_state(i)%trace ()
end do
write (u, "(A)")
call correlated_state%write (u)
write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") &
"Trace = ", correlated_state%trace ()
do i = 1, size(single_state)
call single_state(i)%final ()
end do
call correlated_state%final ()
end do
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call state%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: state_matrix_2"
end subroutine state_matrix_2
@ %def state_matrix_2
@ Create a colored state matrix and add color contractions.
<<State matrices: execute tests>>=
call test (state_matrix_3, "state_matrix_3", &
"check factorizing 3-particle state matrix", &
u, results)
<<State matrices: test declarations>>=
public :: state_matrix_3
<<State matrices: tests>>=
subroutine state_matrix_3 (u)
use physics_defs, only: HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET
integer, intent(in) :: u
type(state_matrix_t) :: state
type(flavor_t), dimension(4) :: flv
type(color_t), dimension(4) :: col
type(quantum_numbers_t), dimension(4) :: qn
write (u, "(A)") "* Test output: state_matrix_3"
write (u, "(A)") "* Purpose: add color connections to colored state"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call state%init ()
call flv%init ([ 1, -HADRON_REMNANT_TRIPLET, -1, HADRON_REMNANT_TRIPLET ])
call col(1)%init ([17])
call col(2)%init ([-17])
call col(3)%init ([-19])
call col(4)%init ([19])
call qn%init (flv, col)
call state%add_state (qn)
call flv%init ([ 1, -HADRON_REMNANT_TRIPLET, 21, HADRON_REMNANT_OCTET ])
call col(1)%init ([17])
call col(2)%init ([-17])
call col(3)%init ([3, -5])
call col(4)%init ([5, -3])
call qn%init (flv, col)
call state%add_state (qn)
call state%freeze ()
write (u, "(A)") "* State:"
write (u, "(A)")
call state%write (u)
call state%add_color_contractions ()
write (u, "(A)") "* State with contractions:"
write (u, "(A)")
call state%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call state%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: state_matrx_3"
end subroutine state_matrix_3
@ %def state_matrix_3
@ Create a correlated three-particle state matrix, write it to file
and read again.
<<State matrices: execute tests>>=
call test (state_matrix_4, "state_matrix_4", &
"check raw I/O", &
u, results)
<<State matrices: test declarations>>=
public :: state_matrix_4
<<State matrices: tests>>=
subroutine state_matrix_4 (u)
integer, intent(in) :: u
type(state_matrix_t), allocatable :: state
integer :: f, h11, h12, h21, h22, i
type(flavor_t), dimension(2) :: flv
type(color_t), dimension(2) :: col
type(helicity_t), dimension(2) :: hel
type(quantum_numbers_t), dimension(2) :: qn
integer :: unit, iostat
write (u, "(A)")
write (u, "(A)") "* Test output: state_matrix_4"
write (u, "(A)") "* Purpose: raw I/O for correlated 3-particle state"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
allocate (state)
call state%init ()
do f = 1, 2
do h11 = -1, 1, 2
do h12 = -1, 1, 2
do h21 = -1, 1, 2
do h22 = -1, 1, 2
call flv%init ([f, -f])
call col(1)%init ([1])
call col(2)%init ([-1])
call hel%init ([h11, h12], [h21, h22])
call qn%init (flv, col, hel)
call state%add_state (qn)
end do
end do
end do
end do
end do
call state%freeze ()
call state%set_norm (3._default)
do i = 1, state%get_n_leaves ()
call state%set_matrix_element (i, cmplx (2 * i, 2 * i + 1, default))
end do
call state%write (u)
write (u, "(A)")
write (u, "(A)") "* Write to file and read again "
write (u, "(A)")
unit = free_unit ()
open (unit, action="readwrite", form="unformatted", status="scratch")
call state%write_raw (unit)
call state%final ()
deallocate (state)
allocate(state)
rewind (unit)
call state%read_raw (unit, iostat=iostat)
close (unit)
call state%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call state%final ()
deallocate (state)
write (u, "(A)")
write (u, "(A)") "* Test output end: state_matrix_4"
end subroutine state_matrix_4
@ %def state_matrix_4
@
Create a flavor-content object for a given state matrix and match it
against trial flavor (i.e., PDG) strings.
<<State matrices: execute tests>>=
call test (state_matrix_5, "state_matrix_5", &
"check flavor content", &
u, results)
<<State matrices: test declarations>>=
public :: state_matrix_5
<<State matrices: tests>>=
subroutine state_matrix_5 (u)
integer, intent(in) :: u
type(state_matrix_t), allocatable, target :: state
type(state_iterator_t) :: it
type(state_flv_content_t), allocatable :: state_flv
type(flavor_t), dimension(4) :: flv1, flv2, flv3, flv4
type(color_t), dimension(4) :: col1, col2
type(helicity_t), dimension(4) :: hel1, hel2, hel3
type(quantum_numbers_t), dimension(4) :: qn
logical, dimension(4) :: mask
write (u, "(A)") "* Test output: state_matrix_5"
write (u, "(A)") "* Purpose: check flavor-content state"
write (u, "(A)")
write (u, "(A)") "* Set up arbitrary state matrix"
write (u, "(A)")
call flv1%init ([1, 4, 2, 7])
call flv2%init ([1, 3,-3, 8])
call flv3%init ([5, 6, 3, 7])
call flv4%init ([6, 3, 5, 8])
call hel1%init ([0, 1, -1, 0])
call hel2%init ([0, 1, 1, 1])
call hel3%init ([1, 0, 0, 0])
call col1(1)%init ([0])
call col1(2)%init ([0])
call col1(3)%init ([0])
call col1(4)%init ([0])
call col2(1)%init ([5, -6])
call col2(2)%init ([0])
call col2(3)%init ([6, -5])
call col2(4)%init ([0])
allocate (state)
call state%init ()
call qn%init (flv1, col1, hel1)
call state%add_state (qn)
call qn%init (flv1, col1, hel2)
call state%add_state (qn)
call qn%init (flv3, col1, hel3)
call state%add_state (qn)
call qn%init (flv4, col1, hel3)
call state%add_state (qn)
call qn%init (flv1, col2, hel3)
call state%add_state (qn)
call qn%init (flv2, col2, hel2)
call state%add_state (qn)
call qn%init (flv2, col2, hel1)
call state%add_state (qn)
call qn%init (flv2, col1, hel1)
call state%add_state (qn)
call qn%init (flv3, col1, hel1)
call state%add_state (qn)
call qn%init (flv3, col2, hel3)
call state%add_state (qn)
call qn%init (flv1, col1, hel1)
call state%add_state (qn)
write (u, "(A)") "* Quantum number content"
write (u, "(A)")
call it%init (state)
do while (it%is_valid ())
call quantum_numbers_write (it%get_quantum_numbers (), u)
write (u, *)
call it%advance ()
end do
write (u, "(A)")
write (u, "(A)") "* Extract the flavor content"
write (u, "(A)")
mask = [.true., .true., .true., .false.]
allocate (state_flv)
call state_flv%fill (state, mask)
call state_flv%write (u)
write (u, "(A)")
write (u, "(A)") "* Match trial sets"
write (u, "(A)")
call check ([1, 2, 3, 0])
call check ([1, 4, 2, 0])
call check ([4, 2, 1, 0])
call check ([1, 3, -3, 0])
call check ([1, -3, 3, 0])
call check ([6, 3, 5, 0])
write (u, "(A)")
write (u, "(A)") "* Determine the flavor content with mask"
write (u, "(A)")
mask = [.false., .true., .true., .false.]
call state_flv%fill (state, mask)
call state_flv%write (u)
write (u, "(A)")
write (u, "(A)") "* Match trial sets"
write (u, "(A)")
call check ([1, 2, 3, 0])
call check ([1, 4, 2, 0])
call check ([4, 2, 1, 0])
call check ([1, 3, -3, 0])
call check ([1, -3, 3, 0])
call check ([6, 3, 5, 0])
write (u, "(A)")
write (u, "(A)") "* Cleanup"
deallocate (state_flv)
call state%final ()
deallocate (state)
write (u, "(A)")
write (u, "(A)") "* Test output end: state_matrix_5"
contains
subroutine check (pdg)
integer, dimension(4), intent(in) :: pdg
integer, dimension(4) :: map
logical :: success
call state_flv%match (pdg, success, map)
write (u, "(2x,4(1x,I0),':',1x,L1)", advance="no") pdg, success
if (success) then
write (u, "(2x,'map = (',4(1x,I0),' )')") map
else
write (u, *)
end if
end subroutine check
end subroutine state_matrix_5
@ %def state_matrix_5
@
Create a state matrix with full flavor, color and helicity information.
Afterwards, reduce such that it is only differential in flavor and
initial-state helicities. This is used when preparing states for beam-
polarized computations with external matrix element providers.
<<State matrices: execute tests>>=
call test (state_matrix_6, "state_matrix_6", &
"check state matrix reduction", &
u, results)
<<State matrices: test declarations>>=
public :: state_matrix_6
<<State matrices: tests>>=
subroutine state_matrix_6 (u)
integer, intent(in) :: u
type(state_matrix_t), allocatable :: state_orig, state_reduced
type(flavor_t), dimension(4) :: flv
type(helicity_t), dimension(4) :: hel
type(color_t), dimension(4) :: col
type(quantum_numbers_t), dimension(4) :: qn
type(quantum_numbers_mask_t), dimension(4) :: qn_mask
integer :: h1, h2, h3 , h4
integer :: n_states = 0
write (u, "(A)") "* Test output: state_matrix_6"
write (u, "(A)") "* Purpose: Check state matrix reduction"
write (u, "(A)")
write (u, "(A)") "* Set up helicity-diagonal state matrix"
write (u, "(A)")
allocate (state_orig)
call state_orig%init ()
call flv%init ([11, -11, 1, -1])
call col(3)%init ([1])
call col(4)%init ([-1])
do h1 = -1, 1, 2
do h2 = -1, 1, 2
do h3 = -1, 1, 2
do h4 = -1, 1, 2
n_states = n_states + 1
call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4])
call qn%init (flv, col, hel)
call state_orig%add_state (qn)
end do
end do
end do
end do
call state_orig%freeze ()
write (u, "(A)") "* Original state: "
write (u, "(A)")
call state_orig%write (u)
write (u, "(A)")
write (u, "(A)") "* Setup quantum mask: "
call qn_mask%init ([.false., .false., .false., .false.], &
[.true., .true., .true., .true.], &
[.false., .false., .true., .true.])
call quantum_numbers_mask_write (qn_mask, u)
write (u, "(A)")
write (u, "(A)") "* Reducing the state matrix using above mask"
write (u, "(A)")
allocate (state_reduced)
call state_orig%reduce (qn_mask, state_reduced)
write (u, "(A)") "* Reduced state matrix: "
call state_reduced%write (u)
write (u, "(A)") "* Test output end: state_matrix_6"
end subroutine state_matrix_6
@ %def state_matrix_6
@
Create a state matrix with full flavor, color and helicity information.
Afterwards, reduce such that it is only differential in flavor and
initial-state helicities, and keeping old indices. Afterwards reorder the
reduced state matrix in accordance to the original state matrix.
<<State matrices: execute tests>>=
call test (state_matrix_7, "state_matrix_7", &
"check ordered state matrix reduction", &
u, results)
<<State matrices: test declarations>>=
public :: state_matrix_7
<<State matrices: tests>>=
subroutine state_matrix_7 (u)
integer, intent(in) :: u
type(state_matrix_t), allocatable :: state_orig, state_reduced, &
state_ordered
type(flavor_t), dimension(4) :: flv
type(helicity_t), dimension(4) :: hel
type(color_t), dimension(4) :: col
type(quantum_numbers_t), dimension(4) :: qn
type(quantum_numbers_mask_t), dimension(4) :: qn_mask
integer :: h1, h2, h3 , h4
integer :: n_states = 0
write (u, "(A)") "* Test output: state_matrix_7"
write (u, "(A)") "* Purpose: Check ordered state matrix reduction"
write (u, "(A)")
write (u, "(A)") "* Set up helicity-diagonal state matrix"
write (u, "(A)")
allocate (state_orig)
call state_orig%init ()
call flv%init ([11, -11, 1, -1])
call col(3)%init ([1])
call col(4)%init ([-1])
do h1 = -1, 1, 2
do h2 = -1, 1, 2
do h3 = -1, 1, 2
do h4 = -1, 1, 2
n_states = n_states + 1
call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4])
call qn%init (flv, col, hel)
call state_orig%add_state (qn)
end do
end do
end do
end do
call state_orig%freeze ()
write (u, "(A)") "* Original state: "
write (u, "(A)")
call state_orig%write (u)
write (u, "(A)")
write (u, "(A)") "* Setup quantum mask: "
call qn_mask%init ([.false., .false., .false., .false.], &
[.true., .true., .true., .true.], &
[.false., .false., .true., .true.])
call quantum_numbers_mask_write (qn_mask, u)
write (u, "(A)")
write (u, "(A)") "* Reducing the state matrix using above mask and keeping the old indices:"
write (u, "(A)")
allocate (state_reduced)
call state_orig%reduce (qn_mask, state_reduced, keep_me_index = .true.)
write (u, "(A)") "* Reduced state matrix with kept indices: "
call state_reduced%write (u)
write (u, "(A)")
write (u, "(A)") "* Reordering reduced state matrix:"
write (u, "(A)")
allocate (state_ordered)
call state_reduced%reorder_me (state_ordered)
write (u, "(A)") "* Reduced and ordered state matrix:"
call state_ordered%write (u)
write (u, "(A)") "* Test output end: state_matrix_6"
end subroutine state_matrix_7
@ %def state_matrix_7
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Interactions}
This module defines the [[interaction_t]] type. It is an extension of
the [[state_matrix_t]] type.
The state matrix is a representation of a multi-particle density
matrix. It implements all possible flavor, color, and quantum-number
assignments of the entries in a generic density matrix, and it can
hold a complex matrix element for each entry. (Note that this matrix
can hold non-diagonal entries in color and helicity space.) The
[[interaction_t]] object associates this with a list of momenta, such
that the whole object represents a multi-particle state.
The [[interaction_t]] holds information about which particles are
incoming, virtual (i.e., kept for the records), or outgoing. Each
particle can be associated to a source within another interaction.
This allows us to automatically fill those interaction momenta which
have been computed or defined elsewhere. It also contains internal
parent-child relations and flags for (virtual) particles which are to
be treated as resonances.
A quantum-number mask array summarizes, for each particle within the
interaction, the treatment of flavor, color, or helicity (expose or
ignore). A list of locks states which particles are bound to have an
identical quantum-number mask. This is useful when the mask is
changed at one place.
<<[[interactions.f90]]>>=
<<File header>>
module interactions
<<Use kinds>>
use lorentz
use flavors
use colors
use helicities
use quantum_numbers
use state_matrices
<<Standard module head>>
<<Interactions: public>>
<<Interactions: types>>
<<Interactions: interfaces>>
interface
<<Interactions: sub interfaces>>
end interface
end module interactions
@ %def interactions
<<[[interactions_sub.f90]]>>=
<<File header>>
submodule (interactions) interactions_s
use io_units
use diagnostics
use sorting
implicit none
contains
<<Interactions: procedures>>
end submodule interactions_s
@ %def interactions_s
@ Given an ordered list of quantum numbers (without any subtraction index) map
this list to a state matrix, such that each list index corresponds to an
index of a set of quantum numbers in the state matrix, hence, the matrix element.
The (unphysical) subtraction index is not a genuine quantum number and as
such handled specially.
<<Interactions: public>>=
public :: qn_index_map_t
<<Interactions: types>>=
type :: qn_index_map_t
private
type(quantum_numbers_t), dimension(:, :), allocatable :: qn_flv
type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel
logical :: flip_hel = .false.
integer :: n_flv = 0, n_hel = 0, n_sub = 0
integer, dimension(:, :, :), allocatable :: index
integer, dimension(:,:), allocatable :: sf_index_born, sf_index_real
contains
<<Interactions: qn index map: TBP>>
end type qn_index_map_t
@ %def qn_index_map_t
@ Construct a mapping from interaction to an array of (sorted) quantum numbers.
We strip all non-elementary particles (like beam) from the quantum numbers which
we retrieve from the interaction.
We consider helicity matrix elements only, when [[qn_hel]] is allocated.
Else the helicity index is handled trivially as [[1]].
For the rescaling of the structure functions in the real subtraction
and DGLAP components we need a mapping (initialized by [[qn_index_map_init_sf]])
from the real and born flavor structure indices to the structure function chain
interaction matrix element with the correct initial state quantum numbers. This is stored
in [[sf_index_born]] and [[sf_index_real]]. The array [[index]] is only needed for the
initialisation of the Born and real index arrays and is therefore deallocated again.
<<Interactions: qn index map: TBP>>=
generic :: init => init_trivial, &
init_involved, &
init_sf
procedure, private :: init_trivial => qn_index_map_init_trivial
procedure, private :: init_involved => qn_index_map_init_involved
procedure, private :: init_sf => qn_index_map_init_sf
<<Interactions: sub interfaces>>=
module subroutine qn_index_map_init_trivial (self, int)
class(qn_index_map_t), intent(out) :: self
class(interaction_t), intent(in) :: int
end subroutine qn_index_map_init_trivial
module subroutine qn_index_map_init_involved (self, int, qn_flv, n_sub, qn_hel)
class(qn_index_map_t), intent(out) :: self
type(interaction_t), intent(in) :: int
type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv
integer, intent(in) :: n_sub
type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel
end subroutine qn_index_map_init_involved
module subroutine qn_index_map_init_sf (self, int, qn_flv, n_flv_born, n_flv_real)
class(qn_index_map_t), intent(out) :: self
type(interaction_t), intent(in) :: int
integer, intent(in) :: n_flv_born, n_flv_real
type(quantum_numbers_t), dimension(:,:), intent(in) :: qn_flv
end subroutine qn_index_map_init_sf
<<Interactions: procedures>>=
module subroutine qn_index_map_init_trivial (self, int)
class(qn_index_map_t), intent(out) :: self
class(interaction_t), intent(in) :: int
integer :: qn
self%n_flv = int%get_n_matrix_elements ()
self%n_hel = 1
self%n_sub = 0
allocate (self%index(self%n_flv, self%n_hel, 0:self%n_sub), source = 0)
do qn = 1, self%n_flv
self%index(qn, 1, 0) = qn
end do
end subroutine qn_index_map_init_trivial
module subroutine qn_index_map_init_involved (self, int, qn_flv, n_sub, qn_hel)
class(qn_index_map_t), intent(out) :: self
type(interaction_t), intent(in) :: int
type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv
integer, intent(in) :: n_sub
type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel
type(quantum_numbers_t), dimension(:), allocatable :: qn, qn_int
integer :: i, i_flv, i_hel, i_sub
self%qn_flv = qn_flv
self%n_flv = size (qn_flv, dim=2)
self%n_sub = n_sub
if (present (qn_hel)) then
if (size (qn_flv, dim=1) /= size (qn_hel, dim=1)) then
call msg_bug ("[qn_index_map_init] number of particles does not match.")
end if
self%qn_hel = qn_hel
self%n_hel = size (qn_hel, dim=2)
else
self%n_hel = 1
end if
allocate (self%index (self%n_flv, self%n_hel, 0:self%n_sub), source=0)
associate (n_me => int%get_n_matrix_elements ())
do i = 1, n_me
qn_int = int%get_quantum_numbers (i, by_me_index = .true.)
qn = pack (qn_int, qn_int%are_hard_process ())
i_flv = find_flv_index (self, qn)
i_hel = 1; if (allocated (self%qn_hel)) &
i_hel = find_hel_index (self, qn)
i_sub = find_sub_index (self, qn)
self%index(i_flv, i_hel, i_sub) = i
end do
end associate
contains
integer function find_flv_index (self, qn) result (i_flv)
type(qn_index_map_t), intent(in) :: self
type(quantum_numbers_t), dimension(:), intent(in) :: qn
integer :: j
i_flv = 0
do j = 1, self%n_flv
if (.not. all (qn .fmatch. self%qn_flv(:, j))) cycle
i_flv = j
exit
end do
if (i_flv < 1) then
call msg_message ("QN:")
call quantum_numbers_write (qn)
call msg_message ("")
call msg_message ("QN_FLV:")
do j = 1, self%n_flv
call quantum_numbers_write (self%qn_flv(:, j))
call msg_message ("")
end do
call msg_bug ("[find_flv_index] could not find flv in qn_flv.")
end if
end function find_flv_index
integer function find_hel_index (self, qn) result (i_hel)
type(qn_index_map_t), intent(in) :: self
type(quantum_numbers_t), dimension(:), intent(in) :: qn
integer :: j
i_hel = 0
do j = 1, self%n_hel
if (.not. all (qn .hmatch. self%qn_hel(:, j))) cycle
i_hel = j
exit
end do
if (i_hel < 1) then
call msg_message ("QN:")
call quantum_numbers_write (qn)
call msg_message ("")
call msg_message ("QN_HEL:")
do j = 1, self%n_hel
call quantum_numbers_write (self%qn_hel(:, j))
call msg_message ("")
end do
call msg_bug ("[find_hel_index] could not find hel in qn_hel.")
end if
end function find_hel_index
integer function find_sub_index (self, qn) result (i_sub)
type(qn_index_map_t), intent(in) :: self
type(quantum_numbers_t), dimension(:), intent(in) :: qn
integer :: s
i_sub = -1
do s = 0, self%n_sub
if ((all (pack(qn%get_sub (), qn%get_sub () > 0) == s)) &
.or. (all (qn%get_sub () == 0) .and. s == 0)) then
i_sub = s
exit
end if
end do
if (i_sub < 0) then
call msg_message ("QN:")
call quantum_numbers_write (qn)
call msg_bug ("[find_sub_index] could not find sub in qn.")
end if
end function find_sub_index
end subroutine qn_index_map_init_involved
module subroutine qn_index_map_init_sf (self, int, qn_flv, n_flv_born, n_flv_real)
class(qn_index_map_t), intent(out) :: self
type(interaction_t), intent(in) :: int
integer, intent(in) :: n_flv_born, n_flv_real
type(quantum_numbers_t), dimension(:,:), intent(in) :: qn_flv
type(quantum_numbers_t), dimension(:,:), allocatable :: qn_int
type(quantum_numbers_t), dimension(:), allocatable :: qn_int_tmp
integer :: i, i_sub, n_flv, n_hard
n_flv = int%get_n_matrix_elements ()
qn_int_tmp = int%get_quantum_numbers (1, by_me_index = .true.)
n_hard = count (qn_int_tmp%are_hard_process ())
allocate (qn_int(n_hard, n_flv))
do i = 1, n_flv
qn_int_tmp = int%get_quantum_numbers (i, by_me_index = .true.)
qn_int(:, i) = pack (qn_int_tmp, qn_int_tmp%are_hard_process ())
end do
call self%init (int, qn_int, int%get_n_sub ())
allocate (self%sf_index_born(n_flv_born, 0:self%n_sub))
allocate (self%sf_index_real(n_flv_real, 0:self%n_sub))
do i_sub = 0, self%n_sub
do i = 1, n_flv_born
self%sf_index_born(i, i_sub) = self%get_index_by_qn (qn_flv(:,i), i_sub)
end do
do i = 1, n_flv_real
self%sf_index_real(i, i_sub) = &
self%get_index_by_qn (qn_flv(:,n_flv_born + i), i_sub)
end do
end do
deallocate (self%index)
end subroutine qn_index_map_init_sf
@ %def qn_index_map_init_trivial
@ %def qn_index_map_init_involved
@ %def qn_index_map_init_sf
@ Write the index map to unit.
<<Interactions: qn index map: TBP>>=
procedure :: write => qn_index_map_write
<<Interactions: sub interfaces>>=
module subroutine qn_index_map_write (self, unit)
class(qn_index_map_t), intent(in) :: self
integer, intent(in), optional :: unit
end subroutine qn_index_map_write
<<Interactions: procedures>>=
module subroutine qn_index_map_write (self, unit)
class(qn_index_map_t), intent(in) :: self
integer, intent(in), optional :: unit
integer :: u, i_flv, i_hel, i_sub
u = given_output_unit (unit); if (u < 0) return
write (u, *) "flip_hel: ", self%flip_hel
do i_flv = 1, self%n_flv
if (allocated (self%qn_flv)) &
call quantum_numbers_write (self%qn_flv(:, i_flv))
write (u, *)
do i_hel = 1, self%n_hel
if (allocated (self%qn_hel)) then
call quantum_numbers_write (self%qn_hel(:, i_hel))
write (u, *)
end if
do i_sub = 0, self%n_sub
write (u, *) &
"(", i_flv, ",", i_hel, ",", i_sub, ") => ", self%index(i_flv, i_hel, i_sub)
end do
end do
end do
end subroutine qn_index_map_write
@ %def qn_index_map_write
@ Set helicity convention. If [[flip]], then we flip the helicities of
anti-particles and we remap the indices accordingly.
<<Interactions: qn index map: TBP>>=
procedure :: set_helicity_flip => qn_index_map_set_helicity_flip
<<Interactions: sub interfaces>>=
module subroutine qn_index_map_set_helicity_flip (self, yorn)
class(qn_index_map_t), intent(inout) :: self
logical, intent(in) :: yorn
end subroutine qn_index_map_set_helicity_flip
<<Interactions: procedures>>=
module subroutine qn_index_map_set_helicity_flip (self, yorn)
class(qn_index_map_t), intent(inout) :: self
logical, intent(in) :: yorn
integer :: i, i_flv, i_hel, i_hel_new
type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel_flip
integer, dimension(:, :, :), allocatable :: index
if (.not. allocated (self%qn_hel)) then
call msg_bug ("[qn_index_map_set_helicity_flip] &
&cannot flip not-given helicity.")
end if
allocate (index (self%n_flv, self%n_hel, 0:self%n_sub), &
source=self%index)
self%flip_hel = yorn
if (self%flip_hel) then
do i_flv = 1, self%n_flv
qn_hel_flip = self%qn_hel
do i_hel = 1, self%n_hel
do i = 1, size (self%qn_flv, dim=1)
if (is_anti_particle (self%qn_flv(i, i_flv))) then
call qn_hel_flip(i, i_hel)%flip_helicity ()
end if
end do
end do
do i_hel = 1, self%n_hel
i_hel_new = find_hel_index (qn_hel_flip, self%qn_hel(:, i_hel))
self%index(i_flv, i_hel_new, :) = index(i_flv, i_hel, :)
end do
end do
end if
contains
logical function is_anti_particle (qn) result (yorn)
type(quantum_numbers_t), intent(in) :: qn
type(flavor_t) :: flv
flv = qn%get_flavor ()
yorn = flv%get_pdg () < 0
end function is_anti_particle
integer function find_hel_index (qn_sort, qn) result (i_hel)
type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_sort
type(quantum_numbers_t), dimension(:), intent(in) :: qn
integer :: j
do j = 1, size(qn_sort, dim=2)
if (.not. all (qn .hmatch. qn_sort(:, j))) cycle
i_hel = j
exit
end do
end function find_hel_index
end subroutine qn_index_map_set_helicity_flip
@ %def qn_index_map_set_helicity_flip
@ Map from the previously given quantum number and subtraction
index (latter ranging from 0 to [[n_sub]]) to the (interaction) matrix element.
<<Interactions: qn index map: TBP>>=
procedure :: get_index => qn_index_map_get_index
<<Interactions: sub interfaces>>=
module function qn_index_map_get_index (self, i_flv, i_hel, i_sub) result (index)
class(qn_index_map_t), intent(in) :: self
integer :: index
integer, intent(in) :: i_flv
integer, intent(in), optional :: i_hel
integer, intent(in), optional :: i_sub
end function qn_index_map_get_index
<<Interactions: procedures>>=
module function qn_index_map_get_index (self, i_flv, i_hel, i_sub) result (index)
class(qn_index_map_t), intent(in) :: self
integer :: index
integer, intent(in) :: i_flv
integer, intent(in), optional :: i_hel
integer, intent(in), optional :: i_sub
integer :: i_sub_opt, i_hel_opt
i_sub_opt = 0; if (present (i_sub)) &
i_sub_opt = i_sub
i_hel_opt = 1; if (present (i_hel)) &
i_hel_opt = i_hel
index = 0
if (.not. allocated (self%index)) then
call msg_bug ("[qn_index_map_get_index] The index map is not allocated.")
end if
index = self%index(i_flv, i_hel_opt, i_sub_opt)
if (index <= 0) then
call self%write ()
call msg_bug ("[qn_index_map_get_index] The index for the given quantum numbers could not be retrieved.")
end if
end function qn_index_map_get_index
@ %def qn_index_map_get_i_flv
@ Get [[n_flv]].
<<Interactions: qn index map: TBP>>=
procedure :: get_n_flv => qn_index_map_get_n_flv
<<Interactions: sub interfaces>>=
module function qn_index_map_get_n_flv (self) result (n_flv)
class(qn_index_map_t), intent(in) :: self
integer :: n_flv
end function qn_index_map_get_n_flv
<<Interactions: procedures>>=
module function qn_index_map_get_n_flv (self) result (n_flv)
class(qn_index_map_t), intent(in) :: self
integer :: n_flv
n_flv = self%n_flv
end function qn_index_map_get_n_flv
@ %def qn_index_map_get_n_flv
@ Get [[n_hel]].
<<Interactions: qn index map: TBP>>=
procedure :: get_n_hel => qn_index_map_get_n_hel
<<Interactions: sub interfaces>>=
module function qn_index_map_get_n_hel (self) result (n_hel)
class(qn_index_map_t), intent(in) :: self
integer :: n_hel
end function qn_index_map_get_n_hel
<<Interactions: procedures>>=
module function qn_index_map_get_n_hel (self) result (n_hel)
class(qn_index_map_t), intent(in) :: self
integer :: n_hel
n_hel = self%n_hel
end function qn_index_map_get_n_hel
@ %def qn_index_map_get_n_flv
@ Get [[n_sub]].
<<Interactions: qn index map: TBP>>=
procedure :: get_n_sub => qn_index_map_get_n_sub
<<Interactions: sub interfaces>>=
module function qn_index_map_get_n_sub (self) result (n_sub)
class(qn_index_map_t), intent(in) :: self
integer :: n_sub
end function qn_index_map_get_n_sub
<<Interactions: procedures>>=
module function qn_index_map_get_n_sub (self) result (n_sub)
class(qn_index_map_t), intent(in) :: self
integer :: n_sub
n_sub = self%n_sub
end function qn_index_map_get_n_sub
@ %def qn_index_map_get_n_sub
@ Gets the index for the matrix element corresponding to a set of quantum numbers.
So far, it ignores helicity (and color) indices.
<<Interactions: qn index map: TBP>>=
procedure :: get_index_by_qn => qn_index_map_get_index_by_qn
<<Interactions: sub interfaces>>=
module function qn_index_map_get_index_by_qn (self, qn, i_sub) result (index)
class(qn_index_map_t), intent(in) :: self
integer :: index
type(quantum_numbers_t), dimension(:), intent(in) :: qn
integer, intent(in), optional :: i_sub
end function qn_index_map_get_index_by_qn
<<Interactions: procedures>>=
module function qn_index_map_get_index_by_qn (self, qn, i_sub) result (index)
class(qn_index_map_t), intent(in) :: self
integer :: index
type(quantum_numbers_t), dimension(:), intent(in) :: qn
integer, intent(in), optional :: i_sub
integer :: i_qn
if (size (qn) /= size (self%qn_flv, dim = 1)) &
call msg_bug ("[qn_index_map_get_index_by_qn] number of particles does not match.")
do i_qn = 1, self%n_flv
if (all (qn .fmatch. self%qn_flv(:, i_qn))) then
index = self%get_index (i_qn, i_sub = i_sub)
return
end if
end do
call self%write ()
call msg_bug ("[qn_index_map_get_index_by_qn] The index for the given quantum &
& numbers could not be retrieved.")
end function qn_index_map_get_index_by_qn
@ %def qn_index_map_get_index_by_qn
@
<<Interactions: qn index map: TBP>>=
procedure :: get_sf_index_born => qn_index_map_get_sf_index_born
<<Interactions: sub interfaces>>=
module function qn_index_map_get_sf_index_born (self, i_born, i_sub) result (index)
class(qn_index_map_t), intent(in) :: self
integer, intent(in) :: i_born, i_sub
integer :: index
end function qn_index_map_get_sf_index_born
<<Interactions: procedures>>=
module function qn_index_map_get_sf_index_born (self, i_born, i_sub) result (index)
class(qn_index_map_t), intent(in) :: self
integer, intent(in) :: i_born, i_sub
integer :: index
index = self%sf_index_born(i_born, i_sub)
end function qn_index_map_get_sf_index_born
@ %def qn_index_map_get_sf_index_born
@
<<Interactions: qn index map: TBP>>=
procedure :: get_sf_index_real => qn_index_map_get_sf_index_real
<<Interactions: sub interfaces>>=
module function qn_index_map_get_sf_index_real (self, i_real, i_sub) result (index)
class(qn_index_map_t), intent(in) :: self
integer, intent(in) :: i_real, i_sub
integer :: index
end function qn_index_map_get_sf_index_real
<<Interactions: procedures>>=
module function qn_index_map_get_sf_index_real (self, i_real, i_sub) result (index)
class(qn_index_map_t), intent(in) :: self
integer, intent(in) :: i_real, i_sub
integer :: index
index = self%sf_index_real(i_real, i_sub)
end function qn_index_map_get_sf_index_real
@ %def qn_index_map_get_sf_index_real
@
\subsection{External interaction links}
Each particle in an interaction can have a link to a corresponding
particle in another interaction. This allows to fetch the momenta of
incoming or virtual particles from the interaction where they are
defined. The link object consists of a pointer to the interaction and
an index.
<<Interactions: types>>=
type :: external_link_t
private
type(interaction_t), pointer :: int => null ()
integer :: i
end type external_link_t
@ %def external_link_t
@ Set an external link.
<<Interactions: sub interfaces>>=
module subroutine external_link_set (link, int, i)
type(external_link_t), intent(out) :: link
type(interaction_t), target, intent(in) :: int
integer, intent(in) :: i
end subroutine external_link_set
<<Interactions: procedures>>=
module subroutine external_link_set (link, int, i)
type(external_link_t), intent(out) :: link
type(interaction_t), target, intent(in) :: int
integer, intent(in) :: i
if (i /= 0) then
link%int => int
link%i = i
end if
end subroutine external_link_set
@ %def external_link_set
@ Reassign an external link to a new interaction (which should be an
image of the original target).
<<Interactions: sub interfaces>>=
module subroutine external_link_reassign (link, int_src, int_target)
type(external_link_t), intent(inout) :: link
type(interaction_t), intent(in) :: int_src
type(interaction_t), intent(in), target :: int_target
end subroutine external_link_reassign
<<Interactions: procedures>>=
module subroutine external_link_reassign (link, int_src, int_target)
type(external_link_t), intent(inout) :: link
type(interaction_t), intent(in) :: int_src
type(interaction_t), intent(in), target :: int_target
if (associated (link%int)) then
if (link%int%tag == int_src%tag) link%int => int_target
end if
end subroutine external_link_reassign
@ %def external_link_reassign
@ Return true if the link is set
<<Interactions: sub interfaces>>=
module function external_link_is_set (link) result (flag)
logical :: flag
type(external_link_t), intent(in) :: link
end function external_link_is_set
<<Interactions: procedures>>=
module function external_link_is_set (link) result (flag)
logical :: flag
type(external_link_t), intent(in) :: link
flag = associated (link%int)
end function external_link_is_set
@ %def external_link_is_set
@ Return the interaction pointer.
<<Interactions: public>>=
public :: external_link_get_ptr
<<Interactions: sub interfaces>>=
module function external_link_get_ptr (link) result (int)
type(interaction_t), pointer :: int
type(external_link_t), intent(in) :: link
end function external_link_get_ptr
<<Interactions: procedures>>=
module function external_link_get_ptr (link) result (int)
type(interaction_t), pointer :: int
type(external_link_t), intent(in) :: link
int => link%int
end function external_link_get_ptr
@ %def external_link_get_ptr
@ Return the index within that interaction
<<Interactions: public>>=
public :: external_link_get_index
<<Interactions: sub interfaces>>=
module function external_link_get_index (link) result (i)
integer :: i
type(external_link_t), intent(in) :: link
end function external_link_get_index
<<Interactions: procedures>>=
module function external_link_get_index (link) result (i)
integer :: i
type(external_link_t), intent(in) :: link
i = link%i
end function external_link_get_index
@ %def external_link_get_index
@ Return a pointer to the momentum of the corresponding particle. If
there is no association, return a null pointer.
<<Interactions: sub interfaces>>=
module function external_link_get_momentum_ptr (link) result (p)
type(vector4_t), pointer :: p
type(external_link_t), intent(in) :: link
end function external_link_get_momentum_ptr
<<Interactions: procedures>>=
module function external_link_get_momentum_ptr (link) result (p)
type(vector4_t), pointer :: p
type(external_link_t), intent(in) :: link
if (associated (link%int)) then
p => link%int%p(link%i)
else
p => null ()
end if
end function external_link_get_momentum_ptr
@ %def external_link_get_momentum_ptr
@
\subsection{Internal relations}
In addition to the external links, particles within the interaction
have parent-child relations. Here, more than one link is possible,
and we set up an array.
<<Interactions: types>>=
type :: internal_link_list_t
private
integer :: length = 0
integer, dimension(:), allocatable :: link
contains
<<Interactions: internal link list: TBP>>
end type internal_link_list_t
@ %def internal_link_t internal_link_list_t
@ Output, non-advancing.
<<Interactions: internal link list: TBP>>=
procedure :: write => internal_link_list_write
<<Interactions: sub interfaces>>=
module subroutine internal_link_list_write (object, unit)
class(internal_link_list_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine internal_link_list_write
<<Interactions: procedures>>=
module subroutine internal_link_list_write (object, unit)
class(internal_link_list_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
do i = 1, object%length
write (u, "(1x,I0)", advance="no") object%link(i)
end do
end subroutine internal_link_list_write
@ %def internal_link_list_write
@ Append an item. Start with an array size of 2 and double the size
if necessary.
Make sure that the indices are stored in ascending order. To this
end, shift the existing entries right, starting from the end, as long
as they are larger than the new entry.
<<Interactions: internal link list: TBP>>=
procedure :: append => internal_link_list_append
<<Interactions: sub interfaces>>=
module subroutine internal_link_list_append (link_list, link)
class(internal_link_list_t), intent(inout) :: link_list
integer, intent(in) :: link
end subroutine internal_link_list_append
<<Interactions: procedures>>=
module subroutine internal_link_list_append (link_list, link)
class(internal_link_list_t), intent(inout) :: link_list
integer, intent(in) :: link
integer :: l, j
integer, dimension(:), allocatable :: tmp
l = link_list%length
if (allocated (link_list%link)) then
if (l == size (link_list%link)) then
allocate (tmp (2 * l))
tmp(:l) = link_list%link
call move_alloc (from = tmp, to = link_list%link)
end if
else
allocate (link_list%link (2))
end if
link_list%link(l+1) = link
SHIFT_LINK_IN_PLACE: do j = l, 1, -1
if (link >= link_list%link(j)) then
exit SHIFT_LINK_IN_PLACE
else
link_list%link(j+1) = link_list%link(j)
link_list%link(j) = link
end if
end do SHIFT_LINK_IN_PLACE
link_list%length = l + 1
end subroutine internal_link_list_append
@ %def internal_link_list_append
@ Return true if the link list is nonempty:
<<Interactions: internal link list: TBP>>=
procedure :: has_entries => internal_link_list_has_entries
<<Interactions: sub interfaces>>=
module function internal_link_list_has_entries (link_list) result (flag)
class(internal_link_list_t), intent(in) :: link_list
logical :: flag
end function internal_link_list_has_entries
<<Interactions: procedures>>=
module function internal_link_list_has_entries (link_list) result (flag)
class(internal_link_list_t), intent(in) :: link_list
logical :: flag
flag = link_list%length > 0
end function internal_link_list_has_entries
@ %def internal_link_list_has_entries
@ Return the list length
<<Interactions: internal link list: TBP>>=
procedure :: get_length => internal_link_list_get_length
<<Interactions: sub interfaces>>=
module function internal_link_list_get_length (link_list) result (length)
class(internal_link_list_t), intent(in) :: link_list
integer :: length
end function internal_link_list_get_length
<<Interactions: procedures>>=
module function internal_link_list_get_length (link_list) result (length)
class(internal_link_list_t), intent(in) :: link_list
integer :: length
length = link_list%length
end function internal_link_list_get_length
@ %def internal_link_list_get_length
@ Return an entry.
<<Interactions: internal link list: TBP>>=
procedure :: get_link => internal_link_list_get_link
<<Interactions: sub interfaces>>=
module function internal_link_list_get_link (link_list, i) result (link)
class(internal_link_list_t), intent(in) :: link_list
integer, intent(in) :: i
integer :: link
end function internal_link_list_get_link
<<Interactions: procedures>>=
module function internal_link_list_get_link (link_list, i) result (link)
class(internal_link_list_t), intent(in) :: link_list
integer, intent(in) :: i
integer :: link
if (i <= link_list%length) then
link = link_list%link(i)
else
call msg_bug ("Internal link list: out of bounds")
end if
end function internal_link_list_get_link
@ %def internal_link_list_get_link
@
\subsection{The interaction type}
An interaction is an entangled system of particles. Thus, the
interaction object consists of two parts: the subevent, and the
quantum state which technically is a trie. The subnode levels beyond
the trie root node are in correspondence to the subevent, so
both should be traversed in parallel.
The subevent is implemented as an allocatable array of
four-momenta. The first [[n_in]] particles are incoming, [[n_vir]]
particles in-between can be kept for bookkeeping, and the last
[[n_out]] particles are outgoing.
Distinct interactions are linked by their particles: for each
particle, we have the possibility of links to corresponding particles
in other interactions. Furthermore, for bookkeeping purposes we have
a self-link array [[relations]] where the parent-child relations are
kept, and a flag array [[resonant]] which is set for an intermediate
resonance.
Each momentum is associated with masks for flavor, color, and
helicity. If a mask entry is set, the associated quantum number is to
be ignored for that particle. If any mask has changed, the flag
[[update]] is set.
We can have particle pairs locked together. If this is the case, the
corresponding mask entries are bound to be equal. This is useful for
particles that go through the interaction.
The interaction tag serves bookkeeping purposes. In particular, it
identifies links in printout.
<<Interactions: public>>=
public :: interaction_t
<<Interactions: types>>=
type :: interaction_t
private
integer :: tag = 0
type(state_matrix_t) :: state_matrix
integer :: n_in = 0
integer :: n_vir = 0
integer :: n_out = 0
integer :: n_tot = 0
logical, dimension(:), allocatable :: p_is_known
type(vector4_t), dimension(:), allocatable :: p
type(external_link_t), dimension(:), allocatable :: source
type(internal_link_list_t), dimension(:), allocatable :: parents
type(internal_link_list_t), dimension(:), allocatable :: children
logical, dimension(:), allocatable :: resonant
type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
integer, dimension(:), allocatable :: hel_lock
logical :: update_state_matrix = .false.
logical :: update_values = .false.
type(qn_index_map_t) :: qn_index
contains
<<Interactions: interaction: TBP>>
end type interaction_t
@ %def interaction_particle_p interaction_t
@ Initialize the particle array with a fixed size. The first [[n_in]]
particles are incoming, the rest outgoing. Masks are optional. There
is also an optional tag. The interaction still needs fixing the
values, but that is to be done after all branches have been added.
Interaction tags are assigned consecutively, using a [[save]]d
variable local to this procedure. If desired, we can provide a seed
for the interaction tags. Such a seed should be positive. The
default seed is one. [[tag=0]] indicates an empty interaction.
If [[set_relations]] is set and true, we establish parent-child
relations for all incoming and outgoing particles. Virtual particles
are skipped; this option is normally used only for interations without
virtual particles.
<<Interactions: interaction: TBP>>=
procedure :: basic_init => interaction_init
<<Interactions: sub interfaces>>=
module subroutine interaction_init &
(int, n_in, n_vir, n_out, &
tag, resonant, mask, hel_lock, set_relations, store_values)
class(interaction_t), intent(out) :: int
integer, intent(in) :: n_in, n_vir, n_out
integer, intent(in), optional :: tag
logical, dimension(:), intent(in), optional :: resonant
type(quantum_numbers_mask_t), dimension(:), intent(in), optional :: mask
integer, dimension(:), intent(in), optional :: hel_lock
logical, intent(in), optional :: set_relations, store_values
end subroutine interaction_init
<<Interactions: procedures>>=
module subroutine interaction_init &
(int, n_in, n_vir, n_out, &
tag, resonant, mask, hel_lock, set_relations, store_values)
class(interaction_t), intent(out) :: int
integer, intent(in) :: n_in, n_vir, n_out
integer, intent(in), optional :: tag
logical, dimension(:), intent(in), optional :: resonant
type(quantum_numbers_mask_t), dimension(:), intent(in), optional :: mask
integer, dimension(:), intent(in), optional :: hel_lock
logical, intent(in), optional :: set_relations, store_values
logical :: set_rel
integer :: i, j
set_rel = .false.; if (present (set_relations)) set_rel = set_relations
call interaction_set_tag (int, tag)
call int%state_matrix%init (store_values)
int%n_in = n_in
int%n_vir = n_vir
int%n_out = n_out
int%n_tot = n_in + n_vir + n_out
allocate (int%p_is_known (int%n_tot))
int%p_is_known = .false.
allocate (int%p (int%n_tot))
allocate (int%source (int%n_tot))
allocate (int%parents (int%n_tot))
allocate (int%children (int%n_tot))
allocate (int%resonant (int%n_tot))
if (present (resonant)) then
int%resonant = resonant
else
int%resonant = .false.
end if
allocate (int%mask (int%n_tot))
allocate (int%hel_lock (int%n_tot))
if (present (mask)) then
int%mask = mask
end if
if (present (hel_lock)) then
int%hel_lock = hel_lock
else
int%hel_lock = 0
end if
int%update_state_matrix = .false.
int%update_values = .true.
if (set_rel) then
do i = 1, n_in
do j = 1, n_out
call int%relate (i, n_in + j)
end do
end do
end if
end subroutine interaction_init
@ %def interaction_init
@
<<Interactions: interaction: TBP>>=
generic :: init_qn_index => init_qn_index_trivial, &
init_qn_index_involved, &
init_qn_index_sf
procedure :: init_qn_index_trivial => interaction_init_qn_index_trivial
procedure :: init_qn_index_involved => interaction_init_qn_index_involved
procedure :: init_qn_index_sf => interaction_init_qn_index_sf
<<Interactions: sub interfaces>>=
module subroutine interaction_init_qn_index_trivial (int)
class(interaction_t), intent(inout) :: int
end subroutine interaction_init_qn_index_trivial
module subroutine interaction_init_qn_index_involved (int, qn_flv, n_sub, qn_hel)
class(interaction_t), intent(inout) :: int
type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv
integer, intent(in) :: n_sub
type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel
end subroutine interaction_init_qn_index_involved
module subroutine interaction_init_qn_index_sf (int, qn_flv, n_flv_born, n_flv_real)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: n_flv_born, n_flv_real
type(quantum_numbers_t), dimension(:,:), intent(in) :: qn_flv
end subroutine interaction_init_qn_index_sf
<<Interactions: procedures>>=
module subroutine interaction_init_qn_index_trivial (int)
class(interaction_t), intent(inout) :: int
call int%qn_index%init (int)
end subroutine interaction_init_qn_index_trivial
module subroutine interaction_init_qn_index_involved (int, qn_flv, n_sub, qn_hel)
class(interaction_t), intent(inout) :: int
type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv
integer, intent(in) :: n_sub
type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel
call int%qn_index%init (int, qn_flv, n_sub, qn_hel)
end subroutine interaction_init_qn_index_involved
module subroutine interaction_init_qn_index_sf (int, qn_flv, n_flv_born, n_flv_real)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: n_flv_born, n_flv_real
type(quantum_numbers_t), dimension(:,:), intent(in) :: qn_flv
call int%qn_index%init (int, qn_flv, n_flv_born, n_flv_real)
end subroutine interaction_init_qn_index_sf
@ %def interaction_init_qn_index_trivial
@ %def interaction_init_qn_index
@ %def interaction_init_qn_index_sf
@
<<Interactions: interaction: TBP>>=
procedure :: set_qn_index_helicity_flip => interaction_set_qn_index_helicity_flip
<<Interactions: sub interfaces>>=
module subroutine interaction_set_qn_index_helicity_flip (int, yorn)
class(interaction_t), intent(inout) :: int
logical, intent(in) :: yorn
end subroutine interaction_set_qn_index_helicity_flip
<<Interactions: procedures>>=
module subroutine interaction_set_qn_index_helicity_flip (int, yorn)
class(interaction_t), intent(inout) :: int
logical, intent(in) :: yorn
call int%qn_index%set_helicity_flip (yorn)
end subroutine interaction_set_qn_index_helicity_flip
@ %def interaction_get_qn_index_n_flv
@
<<Interactions: interaction: TBP>>=
procedure :: get_qn_index => interaction_get_qn_index
procedure :: get_sf_qn_index_born => interaction_get_sf_qn_index_born
procedure :: get_sf_qn_index_real => interaction_get_sf_qn_index_real
<<Interactions: sub interfaces>>=
module function interaction_get_qn_index (int, i_flv, i_hel, i_sub) result (index)
class(interaction_t), intent(in) :: int
integer :: index
integer, intent(in) :: i_flv
integer, intent(in), optional :: i_hel
integer, intent(in), optional :: i_sub
end function interaction_get_qn_index
module function interaction_get_sf_qn_index_born (int, i_born, i_sub) result (index)
class(interaction_t), intent(in) :: int
integer :: index
integer, intent(in) :: i_born, i_sub
end function interaction_get_sf_qn_index_born
module function interaction_get_sf_qn_index_real (int, i_real, i_sub) result (index)
class(interaction_t), intent(in) :: int
integer :: index
integer, intent(in) :: i_real, i_sub
end function interaction_get_sf_qn_index_real
<<Interactions: procedures>>=
module function interaction_get_qn_index (int, i_flv, i_hel, i_sub) result (index)
class(interaction_t), intent(in) :: int
integer :: index
integer, intent(in) :: i_flv
integer, intent(in), optional :: i_hel
integer, intent(in), optional :: i_sub
index = int%qn_index%get_index (i_flv, i_hel, i_sub)
end function interaction_get_qn_index
module function interaction_get_sf_qn_index_born (int, i_born, i_sub) result (index)
class(interaction_t), intent(in) :: int
integer :: index
integer, intent(in) :: i_born, i_sub
index = int%qn_index%get_sf_index_born (i_born, i_sub)
end function interaction_get_sf_qn_index_born
module function interaction_get_sf_qn_index_real (int, i_real, i_sub) result (index)
class(interaction_t), intent(in) :: int
integer :: index
integer, intent(in) :: i_real, i_sub
index = int%qn_index%get_sf_index_real (i_real, i_sub)
end function interaction_get_sf_qn_index_real
@ %def interaction_get_qn_index
@ %def interaction_get_sf_qn_index_born
@ %def interaction_get_sf_qn_index_real
@
<<Interactions: interaction: TBP>>=
procedure :: get_qn_index_n_flv => interaction_get_qn_index_n_flv
procedure :: get_qn_index_n_hel => interaction_get_qn_index_n_hel
procedure :: get_qn_index_n_sub => interaction_get_qn_index_n_sub
<<Interactions: sub interfaces>>=
module function interaction_get_qn_index_n_flv (int) result (index)
class(interaction_t), intent(in) :: int
integer :: index
end function interaction_get_qn_index_n_flv
module function interaction_get_qn_index_n_hel (int) result (index)
class(interaction_t), intent(in) :: int
integer :: index
end function interaction_get_qn_index_n_hel
module function interaction_get_qn_index_n_sub (int) result (index)
class(interaction_t), intent(in) :: int
integer :: index
end function interaction_get_qn_index_n_sub
<<Interactions: procedures>>=
module function interaction_get_qn_index_n_flv (int) result (index)
class(interaction_t), intent(in) :: int
integer :: index
index = int%qn_index%get_n_flv ()
end function interaction_get_qn_index_n_flv
module function interaction_get_qn_index_n_hel (int) result (index)
class(interaction_t), intent(in) :: int
integer :: index
index = int%qn_index%get_n_hel ()
end function interaction_get_qn_index_n_hel
module function interaction_get_qn_index_n_sub (int) result (index)
class(interaction_t), intent(in) :: int
integer :: index
index = int%qn_index%get_n_sub ()
end function interaction_get_qn_index_n_sub
@ %def interaction_get_qn_index_n_flv
@ %def interaction_get_qn_index_n_hel
@ %def interaction_get_qn_index_n_sub
@ Set or create a unique tag for the interaction. Without
interaction, reset the tag counter.
<<Interactions: sub interfaces>>=
module subroutine interaction_set_tag (int, tag)
type(interaction_t), intent(inout), optional :: int
integer, intent(in), optional :: tag
end subroutine interaction_set_tag
<<Interactions: procedures>>=
module subroutine interaction_set_tag (int, tag)
type(interaction_t), intent(inout), optional :: int
integer, intent(in), optional :: tag
integer, save :: stored_tag = 1
if (present (int)) then
if (present (tag)) then
int%tag = tag
else
int%tag = stored_tag
stored_tag = stored_tag + 1
end if
else if (present (tag)) then
stored_tag = tag
else
stored_tag = 1
end if
end subroutine interaction_set_tag
@ %def interaction_set_tag
@ The public interface for the previous procedure only covers the
reset functionality.
<<Interactions: public>>=
public :: reset_interaction_counter
<<Interactions: sub interfaces>>=
module subroutine reset_interaction_counter (tag)
integer, intent(in), optional :: tag
end subroutine reset_interaction_counter
<<Interactions: procedures>>=
module subroutine reset_interaction_counter (tag)
integer, intent(in), optional :: tag
call interaction_set_tag (tag=tag)
end subroutine reset_interaction_counter
@ %def reset_interaction_counter
@ Finalizer: The state-matrix object contains pointers.
<<Interactions: interaction: TBP>>=
procedure :: final => interaction_final
<<Interactions: sub interfaces>>=
module subroutine interaction_final (object)
class(interaction_t), intent(inout) :: object
end subroutine interaction_final
<<Interactions: procedures>>=
module subroutine interaction_final (object)
class(interaction_t), intent(inout) :: object
call object%state_matrix%final ()
end subroutine interaction_final
@ %def interaction_final
@ Output. The [[verbose]] option refers to the state matrix output.
<<Interactions: interaction: TBP>>=
procedure :: basic_write => interaction_write
<<Interactions: sub interfaces>>=
module subroutine interaction_write &
(int, unit, verbose, show_momentum_sum, show_mass, show_state, &
col_verbose, testflag)
class(interaction_t), intent(in) :: int
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
logical, intent(in), optional :: show_state, col_verbose, testflag
end subroutine interaction_write
<<Interactions: procedures>>=
module subroutine interaction_write &
(int, unit, verbose, show_momentum_sum, show_mass, show_state, &
col_verbose, testflag)
class(interaction_t), intent(in) :: int
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
logical, intent(in), optional :: show_state, col_verbose, testflag
integer :: u
integer :: i, index_link
type(interaction_t), pointer :: int_link
logical :: show_st
u = given_output_unit (unit); if (u < 0) return
show_st = .true.; if (present (show_state)) show_st = show_state
if (int%tag /= 0) then
write (u, "(1x,A,I0)") "Interaction: ", int%tag
do i = 1, int%n_tot
if (i == 1 .and. int%n_in > 0) then
write (u, "(1x,A)") "Incoming:"
else if (i == int%n_in + 1 .and. int%n_vir > 0) then
write (u, "(1x,A)") "Virtual:"
else if (i == int%n_in + int%n_vir + 1 .and. int%n_out > 0) then
write (u, "(1x,A)") "Outgoing:"
end if
write (u, "(1x,A,1x,I0)", advance="no") "Particle", i
if (allocated (int%resonant)) then
if (int%resonant(i)) then
write (u, "(A)") "[r]"
else
write (u, *)
end if
else
write (u, *)
end if
if (allocated (int%p)) then
if (int%p_is_known(i)) then
call vector4_write (int%p(i), u, show_mass, testflag)
else
write (u, "(A)") " [momentum undefined]"
end if
else
write (u, "(A)") " [momentum not allocated]"
end if
if (allocated (int%mask)) then
write (u, "(1x,A)", advance="no") "mask [fch] = "
call int%mask(i)%write (u)
write (u, *)
end if
if (int%parents(i)%has_entries () &
.or. int%children(i)%has_entries ()) then
write (u, "(1x,A)", advance="no") "internal links:"
call int%parents(i)%write (u)
if (int%parents(i)%has_entries ()) &
write (u, "(1x,A)", advance="no") "=>"
write (u, "(1x,A)", advance="no") "X"
if (int%children(i)%has_entries ()) &
write (u, "(1x,A)", advance="no") "=>"
call int%children(i)%write (u)
write (u, *)
end if
if (allocated (int%hel_lock)) then
if (int%hel_lock(i) /= 0) then
write (u, "(1x,A,1x,I0)") "helicity lock:", int%hel_lock(i)
end if
end if
if (external_link_is_set (int%source(i))) then
write (u, "(1x,A)", advance="no") "source:"
int_link => external_link_get_ptr (int%source(i))
index_link = external_link_get_index (int%source(i))
write (u, "(1x,'(',I0,')',I0)", advance="no") &
int_link%tag, index_link
write (u, *)
end if
end do
if (present (show_momentum_sum)) then
if (allocated (int%p) .and. show_momentum_sum) then
write (u, "(1x,A)") "Incoming particles (sum):"
call vector4_write &
(sum (int%p(1 : int%n_in)), u, show_mass = show_mass)
write (u, "(1x,A)") "Outgoing particles (sum):"
call vector4_write &
(sum (int%p(int%n_in + int%n_vir + 1 : )), &
u, show_mass = show_mass)
write (u, *)
end if
end if
if (show_st) then
call int%write_state_matrix (write_value_list = verbose, &
verbose = verbose, unit = unit, col_verbose = col_verbose, &
testflag = testflag)
end if
else
write (u, "(1x,A)") "Interaction: [empty]"
end if
end subroutine interaction_write
@ %def interaction_write
@
<<Interactions: interaction: TBP>>=
procedure :: write_state_matrix => interaction_write_state_matrix
<<Interactions: sub interfaces>>=
module subroutine interaction_write_state_matrix (int, unit, write_value_list, &
verbose, col_verbose, testflag)
class(interaction_t), intent(in) :: int
logical, intent(in), optional :: write_value_list, verbose, col_verbose
logical, intent(in), optional :: testflag
integer, intent(in), optional :: unit
end subroutine interaction_write_state_matrix
<<Interactions: procedures>>=
module subroutine interaction_write_state_matrix (int, unit, write_value_list, &
verbose, col_verbose, testflag)
class(interaction_t), intent(in) :: int
logical, intent(in), optional :: write_value_list, verbose, col_verbose
logical, intent(in), optional :: testflag
integer, intent(in), optional :: unit
call int%state_matrix%write (write_value_list = verbose, &
verbose = verbose, unit = unit, col_verbose = col_verbose, &
testflag = testflag)
end subroutine interaction_write_state_matrix
@ %def interaction_write_state_matrix
@ Reduce the [[state_matrix]] over the quantum mask. During the reduce procedure
the iterator does not conserve the order of the matrix element respective their
quantum numbers. Setting the [[keep_order]] results in a reorder state matrix
with reintroduced matrix element indices.
<<Interactions: interaction: TBP>>=
procedure :: reduce_state_matrix => interaction_reduce_state_matrix
<<Interactions: sub interfaces>>=
module subroutine interaction_reduce_state_matrix (int, qn_mask, keep_order)
class(interaction_t), intent(inout) :: int
type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask
logical, optional, intent(in) :: keep_order
end subroutine interaction_reduce_state_matrix
<<Interactions: procedures>>=
module subroutine interaction_reduce_state_matrix (int, qn_mask, keep_order)
class(interaction_t), intent(inout) :: int
type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask
logical, optional, intent(in) :: keep_order
type(state_matrix_t) :: state
logical :: opt_keep_order
opt_keep_order = .false.
if (present (keep_order)) opt_keep_order = keep_order
call int%state_matrix%reduce (qn_mask, state, keep_me_index = keep_order)
int%state_matrix = state
if (opt_keep_order) then
call int%state_matrix%reorder_me (state)
int%state_matrix = state
end if
end subroutine interaction_reduce_state_matrix
@ %def interaction_reduce_state_matrix
@ Assignment: We implement this as a deep copy. This applies, in
particular, to the state-matrix and internal-link components.
Furthermore, the new interaction acquires a new tag.
<<Interactions: public>>=
public :: assignment(=)
<<Interactions: interfaces>>=
interface assignment(=)
module procedure interaction_assign
end interface
<<Interactions: sub interfaces>>=
module subroutine interaction_assign (int_out, int_in)
type(interaction_t), intent(out) :: int_out
type(interaction_t), intent(in), target :: int_in
end subroutine interaction_assign
<<Interactions: procedures>>=
module subroutine interaction_assign (int_out, int_in)
type(interaction_t), intent(out) :: int_out
type(interaction_t), intent(in), target :: int_in
call interaction_set_tag (int_out)
int_out%state_matrix = int_in%state_matrix
int_out%n_in = int_in%n_in
int_out%n_out = int_in%n_out
int_out%n_vir = int_in%n_vir
int_out%n_tot = int_in%n_tot
if (allocated (int_in%p_is_known)) then
allocate (int_out%p_is_known (size (int_in%p_is_known)))
int_out%p_is_known = int_in%p_is_known
end if
if (allocated (int_in%p)) then
allocate (int_out%p (size (int_in%p)))
int_out%p = int_in%p
end if
if (allocated (int_in%source)) then
allocate (int_out%source (size (int_in%source)))
int_out%source = int_in%source
end if
if (allocated (int_in%parents)) then
allocate (int_out%parents (size (int_in%parents)))
int_out%parents = int_in%parents
end if
if (allocated (int_in%children)) then
allocate (int_out%children (size (int_in%children)))
int_out%children = int_in%children
end if
if (allocated (int_in%resonant)) then
allocate (int_out%resonant (size (int_in%resonant)))
int_out%resonant = int_in%resonant
end if
if (allocated (int_in%mask)) then
allocate (int_out%mask (size (int_in%mask)))
int_out%mask = int_in%mask
end if
if (allocated (int_in%hel_lock)) then
allocate (int_out%hel_lock (size (int_in%hel_lock)))
int_out%hel_lock = int_in%hel_lock
end if
int_out%update_state_matrix = int_in%update_state_matrix
int_out%update_values = int_in%update_values
end subroutine interaction_assign
@ %def interaction_assign
@
\subsection{Methods inherited from the state matrix member}
Until F2003 is standard, we cannot implement inheritance directly.
Therefore, we need wrappers for ``inherited'' methods.
Make a new branch in the state matrix if it does not yet exist. This
is not just a wrapper but it introduces the interaction mask: where a
quantum number is masked, it is not transferred but set undefined.
After this, the value array has to be updated.
<<Interactions: interaction: TBP>>=
procedure :: add_state => interaction_add_state
<<Interactions: sub interfaces>>=
module subroutine interaction_add_state &
(int, qn, index, value, sum_values, counter_index, ignore_sub_for_qn, me_index)
class(interaction_t), intent(inout) :: int
type(quantum_numbers_t), dimension(:), intent(in) :: qn
integer, intent(in), optional :: index
complex(default), intent(in), optional :: value
logical, intent(in), optional :: sum_values
integer, intent(in), optional :: counter_index
logical, intent(in), optional :: ignore_sub_for_qn
integer, intent(out), optional :: me_index
end subroutine interaction_add_state
<<Interactions: procedures>>=
module subroutine interaction_add_state &
(int, qn, index, value, sum_values, counter_index, ignore_sub_for_qn, me_index)
class(interaction_t), intent(inout) :: int
type(quantum_numbers_t), dimension(:), intent(in) :: qn
integer, intent(in), optional :: index
complex(default), intent(in), optional :: value
logical, intent(in), optional :: sum_values
integer, intent(in), optional :: counter_index
logical, intent(in), optional :: ignore_sub_for_qn
integer, intent(out), optional :: me_index
type(quantum_numbers_t), dimension(size(qn)) :: qn_tmp
qn_tmp = qn
call qn_tmp%undefine (int%mask)
call int%state_matrix%add_state (qn_tmp, index, value, sum_values, &
counter_index, ignore_sub_for_qn, me_index)
int%update_values = .true.
end subroutine interaction_add_state
@ %def interaction_add_state
@
<<Interactions: interaction: TBP>>=
procedure :: set_duplicate_flv_zero => interaction_set_duplicate_flv_zero
<<Interactions: sub interfaces>>=
module subroutine interaction_set_duplicate_flv_zero (int)
class(interaction_t), intent(inout) :: int
end subroutine interaction_set_duplicate_flv_zero
<<Interactions: procedures>>=
module subroutine interaction_set_duplicate_flv_zero (int)
class(interaction_t), intent(inout) :: int
call int%state_matrix%set_duplicate_flv_zero ()
end subroutine interaction_set_duplicate_flv_zero
@ %def interaction_set_duplicate_flv_zero
@ Freeze the quantum state: First collapse the quantum state, i.e.,
remove quantum numbers if any mask has changed, then fix the array of
value pointers.
<<Interactions: interaction: TBP>>=
procedure :: freeze => interaction_freeze
<<Interactions: sub interfaces>>=
module subroutine interaction_freeze (int)
class(interaction_t), intent(inout) :: int
end subroutine interaction_freeze
<<Interactions: procedures>>=
module subroutine interaction_freeze (int)
class(interaction_t), intent(inout) :: int
if (int%update_state_matrix) then
call int%state_matrix%collapse (int%mask)
int%update_state_matrix = .false.
int%update_values = .true.
end if
if (int%update_values) then
call int%state_matrix%freeze ()
int%update_values = .false.
end if
end subroutine interaction_freeze
@ %def interaction_freeze
@ Return true if the state matrix is empty.
<<Interactions: interaction: TBP>>=
procedure :: is_empty => interaction_is_empty
<<Interactions: sub interfaces>>=
pure module function interaction_is_empty (int) result (flag)
logical :: flag
class(interaction_t), intent(in) :: int
end function interaction_is_empty
<<Interactions: procedures>>=
pure module function interaction_is_empty (int) result (flag)
logical :: flag
class(interaction_t), intent(in) :: int
flag = int%state_matrix%is_empty ()
end function interaction_is_empty
@ %def interaction_is_empty
@ Get the number of values stored in the state matrix:
<<Interactions: interaction: TBP>>=
procedure :: get_n_matrix_elements => &
interaction_get_n_matrix_elements
<<Interactions: sub interfaces>>=
pure module function interaction_get_n_matrix_elements (int) result (n)
integer :: n
class(interaction_t), intent(in) :: int
end function interaction_get_n_matrix_elements
<<Interactions: procedures>>=
pure module function interaction_get_n_matrix_elements (int) result (n)
integer :: n
class(interaction_t), intent(in) :: int
n = int%state_matrix%get_n_matrix_elements ()
end function interaction_get_n_matrix_elements
@ %def interaction_get_n_matrix_elements
@
<<Interactions: interaction: TBP>>=
procedure :: get_state_depth => interaction_get_state_depth
<<Interactions: sub interfaces>>=
module function interaction_get_state_depth (int) result (n)
integer :: n
class(interaction_t), intent(in) :: int
end function interaction_get_state_depth
<<Interactions: procedures>>=
module function interaction_get_state_depth (int) result (n)
integer :: n
class(interaction_t), intent(in) :: int
n = int%state_matrix%get_depth ()
end function interaction_get_state_depth
@ %def interaction_get_state_depth
@
<<Interactions: interaction: TBP>>=
procedure :: get_n_in_helicities => interaction_get_n_in_helicities
<<Interactions: sub interfaces>>=
module function interaction_get_n_in_helicities (int) result (n_hel)
integer :: n_hel
class(interaction_t), intent(in) :: int
end function interaction_get_n_in_helicities
<<Interactions: procedures>>=
module function interaction_get_n_in_helicities (int) result (n_hel)
integer :: n_hel
class(interaction_t), intent(in) :: int
type(interaction_t) :: int_copy
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
type(quantum_numbers_t), dimension(:,:), allocatable :: qn
integer :: i
allocate (qn_mask (int%n_tot))
do i = 1, int%n_tot
if (i <= int%n_in) then
call qn_mask(i)%init (.true., .true., .false.)
else
call qn_mask(i)%init (.true., .true., .true.)
end if
end do
int_copy = int
call int_copy%set_mask (qn_mask)
call int_copy%freeze ()
allocate (qn (int_copy%state_matrix%get_n_matrix_elements (), &
int_copy%state_matrix%get_depth ()))
qn = int_copy%get_quantum_numbers ()
n_hel = 0
do i = 1, size (qn, dim=1)
if (all (qn(:, i)%get_subtraction_index () == 0)) n_hel = n_hel + 1
end do
call int_copy%final ()
deallocate (qn_mask)
deallocate (qn)
end function interaction_get_n_in_helicities
@ %def interaction_get_n_in_helicities
@ Get the size of the [[me]]-array of the associated state matrix
for debugging purposes
<<Interactions: interaction: TBP>>=
procedure :: get_me_size => interaction_get_me_size
<<Interactions: sub interfaces>>=
pure module function interaction_get_me_size (int) result (n)
integer :: n
class(interaction_t), intent(in) :: int
end function interaction_get_me_size
<<Interactions: procedures>>=
pure module function interaction_get_me_size (int) result (n)
integer :: n
class(interaction_t), intent(in) :: int
n = int%state_matrix%get_me_size ()
end function interaction_get_me_size
@ %def interaction_get_me_size
@ Get the norm of the state matrix (if the norm has been taken out, otherwise
this would be unity).
<<Interactions: interaction: TBP>>=
procedure :: get_norm => interaction_get_norm
<<Interactions: sub interfaces>>=
pure module function interaction_get_norm (int) result (norm)
real(default) :: norm
class(interaction_t), intent(in) :: int
end function interaction_get_norm
<<Interactions: procedures>>=
pure module function interaction_get_norm (int) result (norm)
real(default) :: norm
class(interaction_t), intent(in) :: int
norm = int%state_matrix%get_norm ()
end function interaction_get_norm
@ %def interaction_get_norm
@
<<Interactions: interaction: TBP>>=
procedure :: get_n_sub => interaction_get_n_sub
<<Interactions: sub interfaces>>=
module function interaction_get_n_sub (int) result (n_sub)
integer :: n_sub
class(interaction_t), intent(in) :: int
end function interaction_get_n_sub
<<Interactions: procedures>>=
module function interaction_get_n_sub (int) result (n_sub)
integer :: n_sub
class(interaction_t), intent(in) :: int
n_sub = int%state_matrix%get_n_sub ()
end function interaction_get_n_sub
@ %def interaction_get_n_sub
@ Get the quantum number array that corresponds to a given index.
<<Interactions: interaction: TBP>>=
generic :: get_quantum_numbers => get_quantum_numbers_single, &
get_quantum_numbers_all, &
get_quantum_numbers_all_qn_mask
procedure :: get_quantum_numbers_single => &
interaction_get_quantum_numbers_single
procedure :: get_quantum_numbers_all => &
interaction_get_quantum_numbers_all
procedure :: get_quantum_numbers_all_qn_mask => &
interaction_get_quantum_numbers_all_qn_mask
<<Interactions: sub interfaces>>=
module function interaction_get_quantum_numbers_single (int, i, by_me_index) result (qn)
type(quantum_numbers_t), dimension(:), allocatable :: qn
class(interaction_t), intent(in), target :: int
integer, intent(in) :: i
logical, intent(in), optional :: by_me_index
end function interaction_get_quantum_numbers_single
module function interaction_get_quantum_numbers_all (int) result (qn)
type(quantum_numbers_t), dimension(:,:), allocatable :: qn
class(interaction_t), intent(in), target :: int
end function interaction_get_quantum_numbers_all
module function interaction_get_quantum_numbers_all_qn_mask (int, qn_mask) &
result (qn)
type(quantum_numbers_t), dimension(:,:), allocatable :: qn
class(interaction_t), intent(in) :: int
type(quantum_numbers_mask_t), intent(in) :: qn_mask
end function interaction_get_quantum_numbers_all_qn_mask
<<Interactions: procedures>>=
module function interaction_get_quantum_numbers_single (int, i, by_me_index) result (qn)
type(quantum_numbers_t), dimension(:), allocatable :: qn
class(interaction_t), intent(in), target :: int
integer, intent(in) :: i
logical, intent(in), optional :: by_me_index
allocate (qn (int%state_matrix%get_depth ()))
qn = int%state_matrix%get_quantum_number (i, by_me_index)
end function interaction_get_quantum_numbers_single
module function interaction_get_quantum_numbers_all (int) result (qn)
type(quantum_numbers_t), dimension(:,:), allocatable :: qn
class(interaction_t), intent(in), target :: int
integer :: i
<<Interactions: get quantum numbers all>>
<<Interactions: get quantum numbers all>>=
allocate (qn (int%state_matrix%get_depth(), &
int%state_matrix%get_n_matrix_elements ()))
do i = 1, int%state_matrix%get_n_matrix_elements ()
qn (:, i) = int%state_matrix%get_quantum_number (i)
end do
<<Interactions: procedures>>=
end function interaction_get_quantum_numbers_all
module function interaction_get_quantum_numbers_all_qn_mask (int, qn_mask) &
result (qn)
type(quantum_numbers_t), dimension(:,:), allocatable :: qn
class(interaction_t), intent(in) :: int
type(quantum_numbers_mask_t), intent(in) :: qn_mask
integer :: n_redundant, n_all, n_me
integer :: i
type(quantum_numbers_t), dimension(:,:), allocatable :: qn_all
<<Interactions: get quantum numbers all qn mask>>
<<Interactions: get quantum numbers all qn mask>>=
call int%state_matrix%get_quantum_numbers (qn_all)
n_redundant = count (qn_all%are_redundant (qn_mask))
n_all = size (qn_all)
!!! Number of matrix elements = survivors / n_particles
n_me = (n_all - n_redundant) / int%state_matrix%get_depth ()
allocate (qn (int%state_matrix%get_depth(), n_me))
do i = 1, n_me
if (.not. any (qn_all(i, :)%are_redundant (qn_mask))) &
qn (:, i) = qn_all (i, :)
end do
<<Interactions: procedures>>=
end function interaction_get_quantum_numbers_all_qn_mask
@ %def interaction_get_quantum_numbers_single
@ %def interaction_get_quantum_numbers_all
@ %def interaction_get_quantum_numbers_all_qn_mask
@
@
<<Interactions: interaction: TBP>>=
procedure :: get_quantum_numbers_all_sub => interaction_get_quantum_numbers_all_sub
<<Interactions: sub interfaces>>=
module subroutine interaction_get_quantum_numbers_all_sub (int, qn)
class(interaction_t), intent(in) :: int
type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn
end subroutine interaction_get_quantum_numbers_all_sub
<<Interactions: procedures>>=
module subroutine interaction_get_quantum_numbers_all_sub (int, qn)
class(interaction_t), intent(in) :: int
type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn
integer :: i
<<Interactions: get quantum numbers all>>
end subroutine interaction_get_quantum_numbers_all_sub
@ %def interaction_get_quantum_numbers_all
@
<<Interactions: interaction: TBP>>=
procedure :: get_flavors => interaction_get_flavors
<<Interactions: sub interfaces>>=
module subroutine interaction_get_flavors (int, only_elementary, qn_mask, flv)
class(interaction_t), intent(in), target :: int
logical, intent(in) :: only_elementary
type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask
integer, intent(out), dimension(:,:), allocatable :: flv
end subroutine interaction_get_flavors
<<Interactions: procedures>>=
module subroutine interaction_get_flavors (int, only_elementary, qn_mask, flv)
class(interaction_t), intent(in), target :: int
logical, intent(in) :: only_elementary
type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask
integer, intent(out), dimension(:,:), allocatable :: flv
call int%state_matrix%get_flavors (only_elementary, qn_mask, flv)
end subroutine interaction_get_flavors
@ %def interaction_get_flavors
@
<<Interactions: interaction: TBP>>=
procedure :: get_quantum_numbers_mask => interaction_get_quantum_numbers_mask
<<Interactions: sub interfaces>>=
module subroutine interaction_get_quantum_numbers_mask (int, qn_mask, qn)
class(interaction_t), intent(in) :: int
type(quantum_numbers_mask_t), intent(in) :: qn_mask
type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn
end subroutine interaction_get_quantum_numbers_mask
<<Interactions: procedures>>=
module subroutine interaction_get_quantum_numbers_mask (int, qn_mask, qn)
class(interaction_t), intent(in) :: int
type(quantum_numbers_mask_t), intent(in) :: qn_mask
type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn
integer :: n_redundant, n_all, n_me
integer :: i
type(quantum_numbers_t), dimension(:,:), allocatable :: qn_all
<<Interactions: get quantum numbers all qn mask>>
end subroutine interaction_get_quantum_numbers_mask
@ %def interaction_get_quantum_numbers_mask
@ Get the matrix element that corresponds to a set of quantum
numbers, a given index, or return the whole array.
<<Interactions: interaction: TBP>>=
generic :: get_matrix_element => get_matrix_element_single
generic :: get_matrix_element => get_matrix_element_array
procedure :: get_matrix_element_single => &
interaction_get_matrix_element_single
procedure :: get_matrix_element_array => &
interaction_get_matrix_element_array
<<Interactions: sub interfaces>>=
elemental module function interaction_get_matrix_element_single (int, i) result (me)
complex(default) :: me
class(interaction_t), intent(in) :: int
integer, intent(in) :: i
end function interaction_get_matrix_element_single
<<Interactions: procedures>>=
elemental module function interaction_get_matrix_element_single (int, i) result (me)
complex(default) :: me
class(interaction_t), intent(in) :: int
integer, intent(in) :: i
me = int%state_matrix%get_matrix_element (i)
end function interaction_get_matrix_element_single
@ %def interaction_get_matrix_element_single
<<Interactions: sub interfaces>>=
module function interaction_get_matrix_element_array (int) result (me)
complex(default), dimension(:), allocatable :: me
class(interaction_t), intent(in) :: int
end function interaction_get_matrix_element_array
<<Interactions: procedures>>=
module function interaction_get_matrix_element_array (int) result (me)
complex(default), dimension(:), allocatable :: me
class(interaction_t), intent(in) :: int
allocate (me (int%get_n_matrix_elements ()))
me = int%state_matrix%get_matrix_element ()
end function interaction_get_matrix_element_array
@ %def interaction_get_matrix_element_array
@ Set the complex value(s) stored in the quantum state.
<<Interactions: interaction: TBP>>=
generic :: set_matrix_element => interaction_set_matrix_element_qn, &
interaction_set_matrix_element_all, &
interaction_set_matrix_element_array, &
interaction_set_matrix_element_single, &
interaction_set_matrix_element_clone
procedure :: interaction_set_matrix_element_qn
procedure :: interaction_set_matrix_element_all
procedure :: interaction_set_matrix_element_array
procedure :: interaction_set_matrix_element_single
procedure :: interaction_set_matrix_element_clone
@ %def interaction_set_matrix_element
@ Indirect access via the quantum number array:
<<Interactions: sub interfaces>>=
module subroutine interaction_set_matrix_element_qn (int, qn, val)
class(interaction_t), intent(inout) :: int
type(quantum_numbers_t), dimension(:), intent(in) :: qn
complex(default), intent(in) :: val
end subroutine interaction_set_matrix_element_qn
<<Interactions: procedures>>=
module subroutine interaction_set_matrix_element_qn (int, qn, val)
class(interaction_t), intent(inout) :: int
type(quantum_numbers_t), dimension(:), intent(in) :: qn
complex(default), intent(in) :: val
call int%state_matrix%set_matrix_element (qn, val)
end subroutine interaction_set_matrix_element_qn
@ %def interaction_set_matrix_element
@ Set all entries of the matrix-element array to a given value.
<<Interactions: sub interfaces>>=
module subroutine interaction_set_matrix_element_all (int, value)
class(interaction_t), intent(inout) :: int
complex(default), intent(in) :: value
end subroutine interaction_set_matrix_element_all
<<Interactions: procedures>>=
module subroutine interaction_set_matrix_element_all (int, value)
class(interaction_t), intent(inout) :: int
complex(default), intent(in) :: value
call int%state_matrix%set_matrix_element (value)
end subroutine interaction_set_matrix_element_all
@ %def interaction_set_matrix_element_all
@ Set the matrix-element array directly.
<<Interactions: sub interfaces>>=
module subroutine interaction_set_matrix_element_array (int, value, range)
class(interaction_t), intent(inout) :: int
complex(default), intent(in), dimension(:) :: value
integer, intent(in), dimension(:), optional :: range
end subroutine interaction_set_matrix_element_array
pure module subroutine interaction_set_matrix_element_single (int, i, value)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
complex(default), intent(in) :: value
end subroutine interaction_set_matrix_element_single
<<Interactions: procedures>>=
module subroutine interaction_set_matrix_element_array (int, value, range)
class(interaction_t), intent(inout) :: int
complex(default), intent(in), dimension(:) :: value
integer, intent(in), dimension(:), optional :: range
call int%state_matrix%set_matrix_element (value, range)
end subroutine interaction_set_matrix_element_array
pure module subroutine interaction_set_matrix_element_single (int, i, value)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
complex(default), intent(in) :: value
call int%state_matrix%set_matrix_element (i, value)
end subroutine interaction_set_matrix_element_single
@ %def interaction_set_matrix_element_array
@ %def interaction_set_matrix_element_single
@ Clone from another (matching) interaction.
<<Interactions: sub interfaces>>=
module subroutine interaction_set_matrix_element_clone (int, int1)
class(interaction_t), intent(inout) :: int
class(interaction_t), intent(in) :: int1
end subroutine interaction_set_matrix_element_clone
<<Interactions: procedures>>=
module subroutine interaction_set_matrix_element_clone (int, int1)
class(interaction_t), intent(inout) :: int
class(interaction_t), intent(in) :: int1
call int%state_matrix%set_matrix_element (int1%state_matrix)
end subroutine interaction_set_matrix_element_clone
@ %def interaction_set_matrix_element_clone
@
<<Interactions: interaction: TBP>>=
procedure :: set_only_matrix_element => interaction_set_only_matrix_element
<<Interactions: sub interfaces>>=
module subroutine interaction_set_only_matrix_element (int, i, value)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
complex(default), intent(in) :: value
end subroutine interaction_set_only_matrix_element
<<Interactions: procedures>>=
module subroutine interaction_set_only_matrix_element (int, i, value)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
complex(default), intent(in) :: value
call int%set_matrix_element (cmplx (0, 0, default))
call int%set_matrix_element (i, value)
end subroutine interaction_set_only_matrix_element
@ %def interaction_set_only_matrix_element
@
<<Interactions: interaction: TBP>>=
procedure :: add_to_matrix_element => interaction_add_to_matrix_element
<<Interactions: sub interfaces>>=
module subroutine interaction_add_to_matrix_element (int, qn, value, match_only_flavor)
class(interaction_t), intent(inout) :: int
type(quantum_numbers_t), dimension(:), intent(in) :: qn
complex(default), intent(in) :: value
logical, intent(in), optional :: match_only_flavor
end subroutine interaction_add_to_matrix_element
<<Interactions: procedures>>=
module subroutine interaction_add_to_matrix_element (int, qn, value, match_only_flavor)
class(interaction_t), intent(inout) :: int
type(quantum_numbers_t), dimension(:), intent(in) :: qn
complex(default), intent(in) :: value
logical, intent(in), optional :: match_only_flavor
call int%state_matrix%add_to_matrix_element (qn, value, match_only_flavor)
end subroutine interaction_add_to_matrix_element
@ %def interaction_add_to_matrix_element
@ Get the indices of any diagonal matrix elements.
<<Interactions: interaction: TBP>>=
procedure :: get_diagonal_entries => interaction_get_diagonal_entries
<<Interactions: sub interfaces>>=
module subroutine interaction_get_diagonal_entries (int, i)
class(interaction_t), intent(in) :: int
integer, dimension(:), allocatable, intent(out) :: i
end subroutine interaction_get_diagonal_entries
<<Interactions: procedures>>=
module subroutine interaction_get_diagonal_entries (int, i)
class(interaction_t), intent(in) :: int
integer, dimension(:), allocatable, intent(out) :: i
call int%state_matrix%get_diagonal_entries (i)
end subroutine interaction_get_diagonal_entries
@ %def interaction_get_diagonal_entries
@ Renormalize the state matrix by its trace, if nonzero. The renormalization
is reflected in the state-matrix norm.
<<Interactions: interaction: TBP>>=
procedure :: normalize_by_trace => interaction_normalize_by_trace
<<Interactions: sub interfaces>>=
module subroutine interaction_normalize_by_trace (int)
class(interaction_t), intent(inout) :: int
end subroutine interaction_normalize_by_trace
<<Interactions: procedures>>=
module subroutine interaction_normalize_by_trace (int)
class(interaction_t), intent(inout) :: int
call int%state_matrix%normalize_by_trace ()
end subroutine interaction_normalize_by_trace
@ %def interaction_normalize_by_trace
@ Analogous, but renormalize by maximal (absolute) value.
<<Interactions: interaction: TBP>>=
procedure :: normalize_by_max => interaction_normalize_by_max
<<Interactions: sub interfaces>>=
module subroutine interaction_normalize_by_max (int)
class(interaction_t), intent(inout) :: int
end subroutine interaction_normalize_by_max
<<Interactions: procedures>>=
module subroutine interaction_normalize_by_max (int)
class(interaction_t), intent(inout) :: int
call int%state_matrix%normalize_by_max ()
end subroutine interaction_normalize_by_max
@ %def interaction_normalize_by_max
@ Explicitly set the norm value (of the state matrix).
<<Interactions: interaction: TBP>>=
procedure :: set_norm => interaction_set_norm
<<Interactions: sub interfaces>>=
module subroutine interaction_set_norm (int, norm)
class(interaction_t), intent(inout) :: int
real(default), intent(in) :: norm
end subroutine interaction_set_norm
<<Interactions: procedures>>=
module subroutine interaction_set_norm (int, norm)
class(interaction_t), intent(inout) :: int
real(default), intent(in) :: norm
call int%state_matrix%set_norm (norm)
end subroutine interaction_set_norm
@ %def interaction_set_norm
@
<<Interactions: interaction: TBP>>=
procedure :: set_state_matrix => interaction_set_state_matrix
<<Interactions: sub interfaces>>=
module subroutine interaction_set_state_matrix (int, state)
class(interaction_t), intent(inout) :: int
type(state_matrix_t), intent(in) :: state
end subroutine interaction_set_state_matrix
<<Interactions: procedures>>=
module subroutine interaction_set_state_matrix (int, state)
class(interaction_t), intent(inout) :: int
type(state_matrix_t), intent(in) :: state
int%state_matrix = state
end subroutine interaction_set_state_matrix
@ %def interaction_set_state_matrix
@ Return the maximum absolute value of color indices.
<<Interactions: interaction: TBP>>=
procedure :: get_max_color_value => &
interaction_get_max_color_value
<<Interactions: sub interfaces>>=
module function interaction_get_max_color_value (int) result (cmax)
class(interaction_t), intent(in) :: int
integer :: cmax
end function interaction_get_max_color_value
<<Interactions: procedures>>=
module function interaction_get_max_color_value (int) result (cmax)
class(interaction_t), intent(in) :: int
integer :: cmax
cmax = int%state_matrix%get_max_color_value ()
end function interaction_get_max_color_value
@ %def interaction_get_max_color_value
@ Factorize the state matrix into single-particle state matrices, the
branch selection depending on a (random) value between 0 and 1;
optionally also return a correlated state matrix.
<<Interactions: interaction: TBP>>=
procedure :: factorize => interaction_factorize
<<Interactions: sub interfaces>>=
module subroutine interaction_factorize &
(int, mode, x, ok, single_state, correlated_state, qn_in)
class(interaction_t), intent(in), target :: int
integer, intent(in) :: mode
real(default), intent(in) :: x
logical, intent(out) :: ok
type(state_matrix_t), &
dimension(:), allocatable, intent(out) :: single_state
type(state_matrix_t), intent(out), optional :: correlated_state
type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in
end subroutine interaction_factorize
<<Interactions: procedures>>=
module subroutine interaction_factorize &
(int, mode, x, ok, single_state, correlated_state, qn_in)
class(interaction_t), intent(in), target :: int
integer, intent(in) :: mode
real(default), intent(in) :: x
logical, intent(out) :: ok
type(state_matrix_t), &
dimension(:), allocatable, intent(out) :: single_state
type(state_matrix_t), intent(out), optional :: correlated_state
type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in
call int%state_matrix%factorize &
(mode, x, ok, single_state, correlated_state, qn_in)
end subroutine interaction_factorize
@ %def interaction_factorize
@ Sum all matrix element values
<<Interactions: interaction: TBP>>=
procedure :: sum => interaction_sum
<<Interactions: sub interfaces>>=
module function interaction_sum (int) result (value)
class(interaction_t), intent(in) :: int
complex(default) :: value
end function interaction_sum
<<Interactions: procedures>>=
module function interaction_sum (int) result (value)
class(interaction_t), intent(in) :: int
complex(default) :: value
value = int%state_matrix%sum ()
end function interaction_sum
@ %def interaction_sum
@ Append new states which are color-contracted versions of the
existing states. The matrix element index of each color contraction
coincides with the index of its origin, so no new matrix elements are
generated. After this operation, no [[freeze]] must be performed
anymore.
<<Interactions: interaction: TBP>>=
procedure :: add_color_contractions => &
interaction_add_color_contractions
<<Interactions: sub interfaces>>=
module subroutine interaction_add_color_contractions (int)
class(interaction_t), intent(inout) :: int
end subroutine interaction_add_color_contractions
<<Interactions: procedures>>=
module subroutine interaction_add_color_contractions (int)
class(interaction_t), intent(inout) :: int
call int%state_matrix%add_color_contractions ()
end subroutine interaction_add_color_contractions
@ %def interaction_add_color_contractions
@ Multiply matrix elements from two interactions. Choose the elements
as given by the integer index arrays, multiply them and store the sum
of products in the indicated matrix element. The suffixes mean:
c=conjugate first factor; f=include weighting factor.
<<Interactions: interaction: TBP>>=
procedure :: evaluate_product => interaction_evaluate_product
procedure :: evaluate_product_cf => interaction_evaluate_product_cf
procedure :: evaluate_square_c => interaction_evaluate_square_c
procedure :: evaluate_sum => interaction_evaluate_sum
procedure :: evaluate_me_sum => interaction_evaluate_me_sum
<<Interactions: sub interfaces>>=
pure module subroutine interaction_evaluate_product &
(int, i, int1, int2, index1, index2)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
type(interaction_t), intent(in) :: int1, int2
integer, dimension(:), intent(in) :: index1, index2
end subroutine interaction_evaluate_product
pure module subroutine interaction_evaluate_product_cf &
(int, i, int1, int2, index1, index2, factor)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
type(interaction_t), intent(in) :: int1, int2
integer, dimension(:), intent(in) :: index1, index2
complex(default), dimension(:), intent(in) :: factor
end subroutine interaction_evaluate_product_cf
pure module subroutine interaction_evaluate_square_c (int, i, int1, index1)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
type(interaction_t), intent(in) :: int1
integer, dimension(:), intent(in) :: index1
end subroutine interaction_evaluate_square_c
pure module subroutine interaction_evaluate_sum (int, i, int1, index1)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
type(interaction_t), intent(in) :: int1
integer, dimension(:), intent(in) :: index1
end subroutine interaction_evaluate_sum
pure module subroutine interaction_evaluate_me_sum (int, i, int1, index1)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
type(interaction_t), intent(in) :: int1
integer, dimension(:), intent(in) :: index1
end subroutine interaction_evaluate_me_sum
<<Interactions: procedures>>=
pure module subroutine interaction_evaluate_product &
(int, i, int1, int2, index1, index2)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
type(interaction_t), intent(in) :: int1, int2
integer, dimension(:), intent(in) :: index1, index2
call int%state_matrix%evaluate_product &
(i, int1%state_matrix, int2%state_matrix, &
index1, index2)
end subroutine interaction_evaluate_product
pure module subroutine interaction_evaluate_product_cf &
(int, i, int1, int2, index1, index2, factor)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
type(interaction_t), intent(in) :: int1, int2
integer, dimension(:), intent(in) :: index1, index2
complex(default), dimension(:), intent(in) :: factor
call int%state_matrix%evaluate_product_cf &
(i, int1%state_matrix, int2%state_matrix, &
index1, index2, factor)
end subroutine interaction_evaluate_product_cf
pure module subroutine interaction_evaluate_square_c (int, i, int1, index1)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
type(interaction_t), intent(in) :: int1
integer, dimension(:), intent(in) :: index1
call int%state_matrix%evaluate_square_c (i, int1%state_matrix, index1)
end subroutine interaction_evaluate_square_c
pure module subroutine interaction_evaluate_sum (int, i, int1, index1)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
type(interaction_t), intent(in) :: int1
integer, dimension(:), intent(in) :: index1
call int%state_matrix%evaluate_sum (i, int1%state_matrix, index1)
end subroutine interaction_evaluate_sum
pure module subroutine interaction_evaluate_me_sum (int, i, int1, index1)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
type(interaction_t), intent(in) :: int1
integer, dimension(:), intent(in) :: index1
call int%state_matrix%evaluate_me_sum (i, int1%state_matrix, index1)
end subroutine interaction_evaluate_me_sum
@ %def interaction_evaluate_product
@ %def interaction_evaluate_product_cf
@ %def interaction_evaluate_square_c
@ %def interaction_evaluate_sum
@ %def interaction_evaluate_me_sum
@ Tag quantum numbers of the state matrix as part of the hard process, according
to the indices specified in [[tag]]. If no [[tag]] is given, all quantum numbers are
tagged as part of the hard process.
<<Interactions: interaction: TBP>>=
procedure :: tag_hard_process => interaction_tag_hard_process
<<Interactions: sub interfaces>>=
module subroutine interaction_tag_hard_process (int, tag)
class(interaction_t), intent(inout) :: int
integer, dimension(:), intent(in), optional :: tag
end subroutine interaction_tag_hard_process
<<Interactions: procedures>>=
module subroutine interaction_tag_hard_process (int, tag)
class(interaction_t), intent(inout) :: int
integer, dimension(:), intent(in), optional :: tag
type(state_matrix_t) :: state
call int%state_matrix%tag_hard_process (state, tag)
call int%state_matrix%final ()
int%state_matrix = state
end subroutine interaction_tag_hard_process
@ %def interaction_tag_hard_process
@ Modify hard-interaction flags at the specified particle-position, in-place.
<<Interactions: interaction: TBP>>=
procedure :: retag_hard_process => interaction_retag_hard_process
<<Interactions: sub interfaces>>=
module subroutine interaction_retag_hard_process (int, i, hard)
class(interaction_t), intent(inout), target :: int
integer, intent(in) :: i
logical, intent(in) :: hard
end subroutine interaction_retag_hard_process
<<Interactions: procedures>>=
module subroutine interaction_retag_hard_process (int, i, hard)
class(interaction_t), intent(inout), target :: int
integer, intent(in) :: i
logical, intent(in) :: hard
type(state_iterator_t) :: it
call it%init (int%get_state_matrix_ptr ())
do while (it%is_valid ())
call it%retag_hard_process (i, hard)
call it%advance ()
end do
end subroutine interaction_retag_hard_process
@ %def interaction_retag_hard_process
@
\subsection{Accessing contents}
Return the integer tag.
<<Interactions: interaction: TBP>>=
procedure :: get_tag => interaction_get_tag
<<Interactions: sub interfaces>>=
module function interaction_get_tag (int) result (tag)
class(interaction_t), intent(in) :: int
integer :: tag
end function interaction_get_tag
<<Interactions: procedures>>=
module function interaction_get_tag (int) result (tag)
class(interaction_t), intent(in) :: int
integer :: tag
tag = int%tag
end function interaction_get_tag
@ %def interaction_get_tag
@ Return the number of particles.
<<Interactions: interaction: TBP>>=
procedure :: get_n_tot => interaction_get_n_tot
procedure :: get_n_in => interaction_get_n_in
procedure :: get_n_vir => interaction_get_n_vir
procedure :: get_n_out => interaction_get_n_out
<<Interactions: sub interfaces>>=
pure module function interaction_get_n_tot (object) result (n_tot)
class(interaction_t), intent(in) :: object
integer :: n_tot
end function interaction_get_n_tot
pure module function interaction_get_n_in (object) result (n_in)
class(interaction_t), intent(in) :: object
integer :: n_in
end function interaction_get_n_in
pure module function interaction_get_n_vir (object) result (n_vir)
class(interaction_t), intent(in) :: object
integer :: n_vir
end function interaction_get_n_vir
pure module function interaction_get_n_out (object) result (n_out)
class(interaction_t), intent(in) :: object
integer :: n_out
end function interaction_get_n_out
<<Interactions: procedures>>=
pure module function interaction_get_n_tot (object) result (n_tot)
class(interaction_t), intent(in) :: object
integer :: n_tot
n_tot = object%n_tot
end function interaction_get_n_tot
pure module function interaction_get_n_in (object) result (n_in)
class(interaction_t), intent(in) :: object
integer :: n_in
n_in = object%n_in
end function interaction_get_n_in
pure module function interaction_get_n_vir (object) result (n_vir)
class(interaction_t), intent(in) :: object
integer :: n_vir
n_vir = object%n_vir
end function interaction_get_n_vir
pure module function interaction_get_n_out (object) result (n_out)
class(interaction_t), intent(in) :: object
integer :: n_out
n_out = object%n_out
end function interaction_get_n_out
@ %def interaction_get_n_tot
@ %def interaction_get_n_in interaction_get_n_vir interaction_get_n_out
@ Return a momentum index. The flags specify whether to keep/drop
incoming, virtual, or outgoing momenta. Check for illegal values.
<<Interactions: sub interfaces>>=
module function idx (int, i, outgoing)
integer :: idx
type(interaction_t), intent(in) :: int
integer, intent(in) :: i
logical, intent(in), optional :: outgoing
end function idx
<<Interactions: procedures>>=
module function idx (int, i, outgoing)
integer :: idx
type(interaction_t), intent(in) :: int
integer, intent(in) :: i
logical, intent(in), optional :: outgoing
logical :: in, vir, out
if (present (outgoing)) then
in = .not. outgoing
vir = .false.
out = outgoing
else
in = .true.
vir = .true.
out = .true.
end if
idx = 0
if (in) then
if (vir) then
if (out) then
if (i <= int%n_tot) idx = i
else
if (i <= int%n_in + int%n_vir) idx = i
end if
else if (out) then
if (i <= int%n_in) then
idx = i
else if (i <= int%n_in + int%n_out) then
idx = int%n_vir + i
end if
else
if (i <= int%n_in) idx = i
end if
else if (vir) then
if (out) then
if (i <= int%n_vir + int%n_out) idx = int%n_in + i
else
if (i <= int%n_vir) idx = int%n_in + i
end if
else if (out) then
if (i <= int%n_out) idx = int%n_in + int%n_vir + i
end if
if (idx == 0) then
call int%basic_write ()
print *, i, in, vir, out
call msg_bug (" Momentum index is out of range for this interaction")
end if
end function idx
@ %def idx
@ Return all or just a specific four-momentum.
<<Interactions: interaction: TBP>>=
generic :: get_momenta => get_momenta_all, get_momenta_idx
procedure :: get_momentum => interaction_get_momentum
procedure :: get_momenta_all => interaction_get_momenta_all
procedure :: get_momenta_idx => interaction_get_momenta_idx
<<Interactions: sub interfaces>>=
module function interaction_get_momenta_all (int, outgoing) result (p)
class(interaction_t), intent(in) :: int
type(vector4_t), dimension(:), allocatable :: p
logical, intent(in), optional :: outgoing
end function interaction_get_momenta_all
module function interaction_get_momenta_idx (int, jj) result (p)
class(interaction_t), intent(in) :: int
type(vector4_t), dimension(:), allocatable :: p
integer, dimension(:), intent(in) :: jj
end function interaction_get_momenta_idx
module function interaction_get_momentum (int, i, outgoing) result (p)
class(interaction_t), intent(in) :: int
type(vector4_t) :: p
integer, intent(in) :: i
logical, intent(in), optional :: outgoing
end function interaction_get_momentum
<<Interactions: procedures>>=
module function interaction_get_momenta_all (int, outgoing) result (p)
class(interaction_t), intent(in) :: int
type(vector4_t), dimension(:), allocatable :: p
logical, intent(in), optional :: outgoing
integer :: i
if (present (outgoing)) then
if (outgoing) then
allocate (p (int%n_out))
else
allocate (p (int%n_in))
end if
else
allocate (p (int%n_tot))
end if
do i = 1, size (p)
p(i) = int%p(idx (int, i, outgoing))
end do
end function interaction_get_momenta_all
module function interaction_get_momenta_idx (int, jj) result (p)
class(interaction_t), intent(in) :: int
type(vector4_t), dimension(:), allocatable :: p
integer, dimension(:), intent(in) :: jj
allocate (p (size (jj)))
p = int%p(jj)
end function interaction_get_momenta_idx
module function interaction_get_momentum (int, i, outgoing) result (p)
class(interaction_t), intent(in) :: int
type(vector4_t) :: p
integer, intent(in) :: i
logical, intent(in), optional :: outgoing
p = int%p(idx (int, i, outgoing))
end function interaction_get_momentum
@ %def interaction_get_momenta interaction_get_momentum
@ Return a shallow copy of the state matrix:
<<Interactions: interaction: TBP>>=
procedure :: get_state_matrix_ptr => &
interaction_get_state_matrix_ptr
<<Interactions: sub interfaces>>=
module function interaction_get_state_matrix_ptr (int) result (state)
class(interaction_t), intent(in), target :: int
type(state_matrix_t), pointer :: state
end function interaction_get_state_matrix_ptr
<<Interactions: procedures>>=
module function interaction_get_state_matrix_ptr (int) result (state)
class(interaction_t), intent(in), target :: int
type(state_matrix_t), pointer :: state
state => int%state_matrix
end function interaction_get_state_matrix_ptr
@ %def interaction_get_state_matrix_ptr
@ Return the array of resonance flags
<<Interactions: interaction: TBP>>=
procedure :: get_resonance_flags => interaction_get_resonance_flags
<<Interactions: sub interfaces>>=
module function interaction_get_resonance_flags (int) result (resonant)
class(interaction_t), intent(in) :: int
logical, dimension(size(int%resonant)) :: resonant
end function interaction_get_resonance_flags
<<Interactions: procedures>>=
module function interaction_get_resonance_flags (int) result (resonant)
class(interaction_t), intent(in) :: int
logical, dimension(size(int%resonant)) :: resonant
resonant = int%resonant
end function interaction_get_resonance_flags
@ %def interaction_get_resonance_flags
@ Return the quantum-numbers mask (or part of it)
<<Interactions: interaction: TBP>>=
generic :: get_mask => get_mask_all, get_mask_slice
procedure :: get_mask_all => interaction_get_mask_all
procedure :: get_mask_slice => interaction_get_mask_slice
<<Interactions: sub interfaces>>=
module function interaction_get_mask_all (int) result (mask)
class(interaction_t), intent(in) :: int
type(quantum_numbers_mask_t), dimension(size(int%mask)) :: mask
end function interaction_get_mask_all
module function interaction_get_mask_slice (int, index) result (mask)
class(interaction_t), intent(in) :: int
integer, dimension(:), intent(in) :: index
type(quantum_numbers_mask_t), dimension(size(index)) :: mask
end function interaction_get_mask_slice
<<Interactions: procedures>>=
module function interaction_get_mask_all (int) result (mask)
class(interaction_t), intent(in) :: int
type(quantum_numbers_mask_t), dimension(size(int%mask)) :: mask
mask = int%mask
end function interaction_get_mask_all
module function interaction_get_mask_slice (int, index) result (mask)
class(interaction_t), intent(in) :: int
integer, dimension(:), intent(in) :: index
type(quantum_numbers_mask_t), dimension(size(index)) :: mask
mask = int%mask(index)
end function interaction_get_mask_slice
@ %def interaction_get_mask
@ Compute the invariant mass squared of the incoming particles (if any,
otherwise outgoing).
<<Interactions: interaction: TBP>>=
procedure :: get_s => interaction_get_s
<<Interactions: sub interfaces>>=
module function interaction_get_s (int) result (s)
real(default) :: s
class(interaction_t), intent(in) :: int
end function interaction_get_s
<<Interactions: procedures>>=
module function interaction_get_s (int) result (s)
real(default) :: s
class(interaction_t), intent(in) :: int
if (int%n_in /= 0) then
s = sum (int%p(:int%n_in)) ** 2
else
s = sum (int%p(int%n_vir + 1 : )) ** 2
end if
end function interaction_get_s
@ %def interaction_get_s
@ Compute the Lorentz transformation that transforms the incoming
particles from the center-of-mass frame to the lab frame where they
are given. If the c.m. mass squared is negative or zero, return the
identity.
<<Interactions: interaction: TBP>>=
procedure :: get_cm_transformation => interaction_get_cm_transformation
<<Interactions: sub interfaces>>=
module function interaction_get_cm_transformation (int) result (lt)
type(lorentz_transformation_t) :: lt
class(interaction_t), intent(in) :: int
end function interaction_get_cm_transformation
<<Interactions: procedures>>=
module function interaction_get_cm_transformation (int) result (lt)
type(lorentz_transformation_t) :: lt
class(interaction_t), intent(in) :: int
type(vector4_t) :: p_cm
real(default) :: s
if (int%n_in /= 0) then
p_cm = sum (int%p(:int%n_in))
else
p_cm = sum (int%p(int%n_vir+1:))
end if
s = p_cm ** 2
if (s > 0) then
lt = boost (p_cm, sqrt (s))
else
lt = identity
end if
end function interaction_get_cm_transformation
@ %def interaction_get_cm_transformation
@ Return flavor, momentum, and position of the first outgoing
unstable particle present in the interaction. Note that we need not
iterate through the state matrix; if there is an unstable particle, it
will be present in all state-matrix entries.
<<Interactions: interaction: TBP>>=
procedure :: get_unstable_particle => interaction_get_unstable_particle
<<Interactions: sub interfaces>>=
module subroutine interaction_get_unstable_particle (int, flv, p, i)
class(interaction_t), intent(in), target :: int
type(flavor_t), intent(out) :: flv
type(vector4_t), intent(out) :: p
integer, intent(out) :: i
end subroutine interaction_get_unstable_particle
<<Interactions: procedures>>=
module subroutine interaction_get_unstable_particle (int, flv, p, i)
class(interaction_t), intent(in), target :: int
type(flavor_t), intent(out) :: flv
type(vector4_t), intent(out) :: p
integer, intent(out) :: i
type(state_iterator_t) :: it
type(flavor_t), dimension(int%n_tot) :: flv_array
call it%init (int%state_matrix)
flv_array = it%get_flavor ()
do i = int%n_in + int%n_vir + 1, int%n_tot
if (.not. flv_array(i)%is_stable ()) then
flv = flv_array(i)
p = int%p(i)
return
end if
end do
end subroutine interaction_get_unstable_particle
@ %def interaction_get_unstable_particle
@ Return the complete set of \emph{outgoing} flavors, assuming that
the flavor quantum number is not suppressed.
<<Interactions: interaction: TBP>>=
procedure :: get_flv_out => interaction_get_flv_out
<<Interactions: sub interfaces>>=
module subroutine interaction_get_flv_out (int, flv)
class(interaction_t), intent(in), target :: int
type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv
end subroutine interaction_get_flv_out
<<Interactions: procedures>>=
module subroutine interaction_get_flv_out (int, flv)
class(interaction_t), intent(in), target :: int
type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv
type(state_iterator_t) :: it
type(flavor_t), dimension(:), allocatable :: flv_state
integer :: n_in, n_vir, n_out, n_tot, n_state, i
n_in = int%get_n_in ()
n_vir = int%get_n_vir ()
n_out = int%get_n_out ()
n_tot = int%get_n_tot ()
n_state = int%get_n_matrix_elements ()
allocate (flv (n_out, n_state))
allocate (flv_state (n_tot))
i = 1
call it%init (int%get_state_matrix_ptr ())
do while (it%is_valid ())
flv_state = it%get_flavor ()
flv(:,i) = flv_state(n_in + n_vir + 1 : )
i = i + 1
call it%advance ()
end do
end subroutine interaction_get_flv_out
@ %def interaction_get_flv_out
@ Determine the flavor content of the interaction. We analyze the
state matrix for this, and we select the outgoing particles of the
hard process only for the required mask, which indicates the particles
that can appear in any order in a matching event record.
We have to assume that any radiated particles (beam remnants) appear
at the beginning of the particles marked as outgoing.
<<Interactions: interaction: TBP>>=
procedure :: get_flv_content => interaction_get_flv_content
<<Interactions: sub interfaces>>=
module subroutine interaction_get_flv_content (int, state_flv, n_out_hard)
class(interaction_t), intent(in), target :: int
type(state_flv_content_t), intent(out) :: state_flv
integer, intent(in) :: n_out_hard
end subroutine interaction_get_flv_content
<<Interactions: procedures>>=
module subroutine interaction_get_flv_content (int, state_flv, n_out_hard)
class(interaction_t), intent(in), target :: int
type(state_flv_content_t), intent(out) :: state_flv
integer, intent(in) :: n_out_hard
logical, dimension(:), allocatable :: mask
integer :: n_tot
n_tot = int%get_n_tot ()
allocate (mask (n_tot), source = .false.)
mask(n_tot-n_out_hard + 1 : ) = .true.
call state_flv%fill (int%get_state_matrix_ptr (), mask)
end subroutine interaction_get_flv_content
@ %def interaction_get_flv_content
@
\subsection{Modifying contents}
Set the quantum numbers mask.
<<Interactions: interaction: TBP>>=
procedure :: set_mask => interaction_set_mask
<<Interactions: sub interfaces>>=
module subroutine interaction_set_mask (int, mask)
class(interaction_t), intent(inout) :: int
type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
end subroutine interaction_set_mask
<<Interactions: procedures>>=
module subroutine interaction_set_mask (int, mask)
class(interaction_t), intent(inout) :: int
type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
if (size (int%mask) /= size (mask)) &
call msg_fatal ("Attempting to set mask with unfitting size!")
int%mask = mask
int%update_state_matrix = .true.
end subroutine interaction_set_mask
@ %def interaction_set_mask
@ Merge a particular mask entry, respecting a possible helicity lock for this
entry. We apply an OR relation, which means that quantum numbers are
summed over if either of the two masks requires it.
<<Interactions: procedures>>=
subroutine interaction_merge_mask_entry (int, i, mask)
type(interaction_t), intent(inout) :: int
integer, intent(in) :: i
type(quantum_numbers_mask_t), intent(in) :: mask
type(quantum_numbers_mask_t) :: mask_tmp
integer :: ii
ii = idx (int, i)
if (int%mask(ii) .neqv. mask) then
int%mask(ii) = int%mask(ii) .or. mask
if (int%hel_lock(ii) /= 0) then
call mask_tmp%assign (mask, helicity=.true.)
int%mask(int%hel_lock(ii)) = int%mask(int%hel_lock(ii)) .or. mask_tmp
end if
end if
int%update_state_matrix = .true.
end subroutine interaction_merge_mask_entry
@ %def interaction_merge_mask_entry
@ Fill the momenta array, do not care about the quantum numbers of
particles.
<<Interactions: interaction: TBP>>=
procedure :: reset_momenta => interaction_reset_momenta
procedure :: set_momenta => interaction_set_momenta
procedure :: set_momentum => interaction_set_momentum
<<Interactions: sub interfaces>>=
module subroutine interaction_reset_momenta (int)
class(interaction_t), intent(inout) :: int
end subroutine interaction_reset_momenta
module subroutine interaction_set_momenta (int, p, outgoing)
class(interaction_t), intent(inout) :: int
type(vector4_t), dimension(:), intent(in) :: p
logical, intent(in), optional :: outgoing
end subroutine interaction_set_momenta
module subroutine interaction_set_momentum (int, p, i, outgoing)
class(interaction_t), intent(inout) :: int
type(vector4_t), intent(in) :: p
integer, intent(in) :: i
logical, intent(in), optional :: outgoing
end subroutine interaction_set_momentum
<<Interactions: procedures>>=
module subroutine interaction_reset_momenta (int)
class(interaction_t), intent(inout) :: int
int%p = vector4_null
int%p_is_known = .true.
end subroutine interaction_reset_momenta
module subroutine interaction_set_momenta (int, p, outgoing)
class(interaction_t), intent(inout) :: int
type(vector4_t), dimension(:), intent(in) :: p
logical, intent(in), optional :: outgoing
integer :: i, index
do i = 1, size (p)
index = idx (int, i, outgoing)
int%p(index) = p(i)
int%p_is_known(index) = .true.
end do
end subroutine interaction_set_momenta
module subroutine interaction_set_momentum (int, p, i, outgoing)
class(interaction_t), intent(inout) :: int
type(vector4_t), intent(in) :: p
integer, intent(in) :: i
logical, intent(in), optional :: outgoing
integer :: index
index = idx (int, i, outgoing)
int%p(index) = p
int%p_is_known(index) = .true.
end subroutine interaction_set_momentum
@ %def interaction_reset_momenta
@ %def interaction_set_momenta interaction_set_momentum
@ This more sophisticated version of setting values is used for
structure functions, in particular if nontrivial flavor, color, and
helicity may be present: set values selectively for the given flavors.
If there is more than one flavor, scan the interaction and check for a
matching flavor at the specified particle location. If it matches,
insert the value that corresponds to this flavor.
<<Interactions: interaction: TBP>>=
procedure :: set_flavored_values => interaction_set_flavored_values
<<Interactions: sub interfaces>>=
module subroutine interaction_set_flavored_values (int, value, flv_in, pos)
class(interaction_t), intent(inout) :: int
complex(default), dimension(:), intent(in) :: value
type(flavor_t), dimension(:), intent(in) :: flv_in
integer, intent(in) :: pos
end subroutine interaction_set_flavored_values
<<Interactions: procedures>>=
module subroutine interaction_set_flavored_values (int, value, flv_in, pos)
class(interaction_t), intent(inout) :: int
complex(default), dimension(:), intent(in) :: value
type(flavor_t), dimension(:), intent(in) :: flv_in
integer, intent(in) :: pos
type(state_iterator_t) :: it
type(flavor_t) :: flv
integer :: i
if (size (value) == 1) then
call int%set_matrix_element (value(1))
else
call it%init (int%state_matrix)
do while (it%is_valid ())
flv = it%get_flavor (pos)
SCAN_FLV: do i = 1, size (value)
if (flv == flv_in(i)) then
call it%set_matrix_element (value(i))
exit SCAN_FLV
end if
end do SCAN_FLV
call it%advance ()
end do
end if
end subroutine interaction_set_flavored_values
@ %def interaction_set_flavored_values
@
\subsection{Handling Linked interactions}
Store relations between corresponding particles within one
interaction. The first particle is the parent, the second one the
child. Links are established in both directions.
These relations have no effect on the propagation of momenta etc.,
they are rather used for mother-daughter relations in event output.
<<Interactions: interaction: TBP>>=
procedure :: relate => interaction_relate
<<Interactions: sub interfaces>>=
module subroutine interaction_relate (int, i1, i2)
class(interaction_t), intent(inout), target :: int
integer, intent(in) :: i1, i2
end subroutine interaction_relate
<<Interactions: procedures>>=
module subroutine interaction_relate (int, i1, i2)
class(interaction_t), intent(inout), target :: int
integer, intent(in) :: i1, i2
if (i1 /= 0 .and. i2 /= 0) then
call int%children(i1)%append (i2)
call int%parents(i2)%append (i1)
end if
end subroutine interaction_relate
@ %def interaction_relate
@ Transfer internal parent-child relations defined within interaction
[[int1]] to a new interaction [[int]] where the particle indices are
mapped to. Some particles in [[int1]] may have no image in [[int]].
In that case, a child entry maps to zero, and we skip this relation.
Also transfer resonance flags.
<<Interactions: interaction: TBP>>=
procedure :: transfer_relations => interaction_transfer_relations
<<Interactions: sub interfaces>>=
module subroutine interaction_transfer_relations (int1, int2, map)
class(interaction_t), intent(in) :: int1
class(interaction_t), intent(inout), target :: int2
integer, dimension(:), intent(in) :: map
end subroutine interaction_transfer_relations
<<Interactions: procedures>>=
module subroutine interaction_transfer_relations (int1, int2, map)
class(interaction_t), intent(in) :: int1
class(interaction_t), intent(inout), target :: int2
integer, dimension(:), intent(in) :: map
integer :: i, j, k
do i = 1, size (map)
do j = 1, int1%parents(i)%get_length ()
k = int1%parents(i)%get_link (j)
call int2%relate (map(k), map(i))
end do
if (map(i) /= 0) then
int2%resonant(map(i)) = int1%resonant(i)
end if
end do
end subroutine interaction_transfer_relations
@ %def interaction_transfer_relations
@ Make up internal parent-child relations for the particle(s) that are
connected to a new interaction [[int]].
If [[resonant]] is defined and true, the connections are marked as
resonant in the result interaction. Also, the children of the resonant
connections are untagged if they were tagged with hard-interaction flags
previously.
<<Interactions: interaction: TBP>>=
procedure :: relate_connections => interaction_relate_connections
<<Interactions: sub interfaces>>=
module subroutine interaction_relate_connections &
(int, int_in, connection_index, &
map, map_connections, resonant)
class(interaction_t), intent(inout), target :: int
class(interaction_t), intent(in) :: int_in
integer, dimension(:), intent(in) :: connection_index
integer, dimension(:), intent(in) :: map, map_connections
logical, intent(in), optional :: resonant
end subroutine interaction_relate_connections
<<Interactions: procedures>>=
module subroutine interaction_relate_connections &
(int, int_in, connection_index, &
map, map_connections, resonant)
class(interaction_t), intent(inout), target :: int
class(interaction_t), intent(in) :: int_in
integer, dimension(:), intent(in) :: connection_index
integer, dimension(:), intent(in) :: map, map_connections
logical, intent(in), optional :: resonant
logical :: reson
integer :: i, j, i2, k2
reson = .false.; if (present (resonant)) reson = resonant
do i = 1, size (map_connections)
k2 = connection_index(i)
do j = 1, int_in%children(k2)%get_length ()
i2 = int_in%children(k2)%get_link (j)
call int%relate (map_connections(i), map(i2))
if (reson) call int%retag_hard_process (map(i2), .false.)
end do
int%resonant(map_connections(i)) = reson
end do
end subroutine interaction_relate_connections
@ %def interaction_relate_connections.
@ Return the number of source/target links of the internal connections of
particle [[i]].
<<Interactions: interaction: TBP>>=
procedure :: get_n_children => interaction_get_n_children
procedure :: get_n_parents => interaction_get_n_parents
<<Interactions: sub interfaces>>=
module function interaction_get_n_children (int, i) result (n)
integer :: n
class(interaction_t), intent(in) :: int
integer, intent(in) :: i
end function interaction_get_n_children
module function interaction_get_n_parents (int, i) result (n)
integer :: n
class(interaction_t), intent(in) :: int
integer, intent(in) :: i
end function interaction_get_n_parents
<<Interactions: procedures>>=
module function interaction_get_n_children (int, i) result (n)
integer :: n
class(interaction_t), intent(in) :: int
integer, intent(in) :: i
n = int%children(i)%get_length ()
end function interaction_get_n_children
module function interaction_get_n_parents (int, i) result (n)
integer :: n
class(interaction_t), intent(in) :: int
integer, intent(in) :: i
n = int%parents(i)%get_length ()
end function interaction_get_n_parents
@ %def interaction_get_n_children interaction_get_n_parents
@ Return the source/target links of the internal connections of
particle [[i]] as an array.
<<Interactions: interaction: TBP>>=
procedure :: get_children => interaction_get_children
procedure :: get_parents => interaction_get_parents
<<Interactions: sub interfaces>>=
module function interaction_get_children (int, i) result (idx)
integer, dimension(:), allocatable :: idx
class(interaction_t), intent(in) :: int
integer, intent(in) :: i
end function interaction_get_children
module function interaction_get_parents (int, i) result (idx)
integer, dimension(:), allocatable :: idx
class(interaction_t), intent(in) :: int
integer, intent(in) :: i
end function interaction_get_parents
<<Interactions: procedures>>=
module function interaction_get_children (int, i) result (idx)
integer, dimension(:), allocatable :: idx
class(interaction_t), intent(in) :: int
integer, intent(in) :: i
integer :: k, l
l = int%children(i)%get_length ()
allocate (idx (l))
do k = 1, l
idx(k) = int%children(i)%get_link (k)
end do
end function interaction_get_children
module function interaction_get_parents (int, i) result (idx)
integer, dimension(:), allocatable :: idx
class(interaction_t), intent(in) :: int
integer, intent(in) :: i
integer :: k, l
l = int%parents(i)%get_length ()
allocate (idx (l))
do k = 1, l
idx(k) = int%parents(i)%get_link (k)
end do
end function interaction_get_parents
@ %def interaction_get_children interaction_get_parents
@ Add a source link from an interaction to a corresponding particle
within another interaction. These links affect the propagation of
particles: the two linked particles are considered as the same
particle, outgoing and incoming.
<<Interactions: interaction: TBP>>=
procedure :: set_source_link => interaction_set_source_link
<<Interactions: sub interfaces>>=
module subroutine interaction_set_source_link (int, i, int1, i1)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
class(interaction_t), intent(in), target :: int1
integer, intent(in) :: i1
end subroutine interaction_set_source_link
<<Interactions: procedures>>=
module subroutine interaction_set_source_link (int, i, int1, i1)
class(interaction_t), intent(inout) :: int
integer, intent(in) :: i
class(interaction_t), intent(in), target :: int1
integer, intent(in) :: i1
if (i /= 0) call external_link_set (int%source(i), int1, i1)
end subroutine interaction_set_source_link
@ %def interaction_set_source_link
@ Reassign links to a new interaction (which is an image of the
current interaction).
<<Interactions: public>>=
public :: interaction_reassign_links
<<Interactions: sub interfaces>>=
module subroutine interaction_reassign_links (int, int_src, int_target)
type(interaction_t), intent(inout) :: int
type(interaction_t), intent(in) :: int_src
type(interaction_t), intent(in), target :: int_target
end subroutine interaction_reassign_links
<<Interactions: procedures>>=
module subroutine interaction_reassign_links (int, int_src, int_target)
type(interaction_t), intent(inout) :: int
type(interaction_t), intent(in) :: int_src
type(interaction_t), intent(in), target :: int_target
integer :: i
if (allocated (int%source)) then
do i = 1, size (int%source)
call external_link_reassign (int%source(i), int_src, int_target)
end do
end if
end subroutine interaction_reassign_links
@ %def interaction_reassign_links
@ Since links are one-directional, if we want to follow them backwards
we have to scan all possibilities. This procedure returns the index
of the particle within [[int]] which points to the particle [[i1]]
within interaction [[int1]]. If unsuccessful, return zero.
<<Interactions: public>>=
public :: interaction_find_link
<<Interactions: sub interfaces>>=
module function interaction_find_link (int, int1, i1) result (i)
integer :: i
type(interaction_t), intent(in) :: int, int1
integer, intent(in) :: i1
end function interaction_find_link
<<Interactions: procedures>>=
module function interaction_find_link (int, int1, i1) result (i)
integer :: i
type(interaction_t), intent(in) :: int, int1
integer, intent(in) :: i1
type(interaction_t), pointer :: int_tmp
do i = 1, int%n_tot
int_tmp => external_link_get_ptr (int%source(i))
if (int_tmp%tag == int1%tag) then
if (external_link_get_index (int%source(i)) == i1) return
end if
end do
i = 0
end function interaction_find_link
@ %def interaction_find_link
@ The inverse: return interaction pointer and index for the ultimate source of
[[i]] within [[int]].
<<Interactions: interaction: TBP>>=
procedure :: find_source => interaction_find_source
<<Interactions: sub interfaces>>=
module subroutine interaction_find_source (int, i, int1, i1)
class(interaction_t), intent(in) :: int
integer, intent(in) :: i
type(interaction_t), intent(out), pointer :: int1
integer, intent(out) :: i1
end subroutine interaction_find_source
<<Interactions: procedures>>=
module subroutine interaction_find_source (int, i, int1, i1)
class(interaction_t), intent(in) :: int
integer, intent(in) :: i
type(interaction_t), intent(out), pointer :: int1
integer, intent(out) :: i1
type(external_link_t) :: link
link = interaction_get_ultimate_source (int, i)
int1 => external_link_get_ptr (link)
i1 = external_link_get_index (link)
end subroutine interaction_find_source
@ %def interaction_find_source
@ Follow source links recursively to return the ultimate source of a particle.
<<Interactions: sub interfaces>>=
module function interaction_get_ultimate_source (int, i) result (link)
type(external_link_t) :: link
type(interaction_t), intent(in) :: int
integer, intent(in) :: i
end function interaction_get_ultimate_source
<<Interactions: procedures>>=
module function interaction_get_ultimate_source (int, i) result (link)
type(external_link_t) :: link
type(interaction_t), intent(in) :: int
integer, intent(in) :: i
type(interaction_t), pointer :: int_src
integer :: i_src
link = int%source(i)
if (external_link_is_set (link)) then
do
int_src => external_link_get_ptr (link)
i_src = external_link_get_index (link)
if (external_link_is_set (int_src%source(i_src))) then
link = int_src%source(i_src)
else
exit
end if
end do
end if
end function interaction_get_ultimate_source
@ %def interaction_get_ultimate_source
@ Update mask entries by merging them with corresponding masks in
interactions linked to the current one. The mask determines quantum
numbers which are summed over.
Note that both the mask of the current interaction and the mask of the
linked interaction are updated (side effect!). This ensures that both
agree for the linked particle.
<<Interactions: interaction: TBP>>=
procedure :: exchange_mask => interaction_exchange_mask
<<Interactions: sub interfaces>>=
module subroutine interaction_exchange_mask (int)
class(interaction_t), intent(inout) :: int
end subroutine interaction_exchange_mask
<<Interactions: procedures>>=
module subroutine interaction_exchange_mask (int)
class(interaction_t), intent(inout) :: int
integer :: i, index_link
type(interaction_t), pointer :: int_link
do i = 1, int%n_tot
if (external_link_is_set (int%source(i))) then
int_link => external_link_get_ptr (int%source(i))
index_link = external_link_get_index (int%source(i))
call interaction_merge_mask_entry &
(int, i, int_link%mask(index_link))
call interaction_merge_mask_entry &
(int_link, index_link, int%mask(i))
end if
end do
call int%freeze ()
end subroutine interaction_exchange_mask
@ %def interaction_exchange_mask
@ Copy momenta from interactions linked to the current one.
<<Interactions: interaction: TBP>>=
procedure :: receive_momenta => interaction_receive_momenta
<<Interactions: sub interfaces>>=
module subroutine interaction_receive_momenta (int)
class(interaction_t), intent(inout) :: int
end subroutine interaction_receive_momenta
<<Interactions: procedures>>=
module subroutine interaction_receive_momenta (int)
class(interaction_t), intent(inout) :: int
integer :: i, index_link
type(interaction_t), pointer :: int_link
do i = 1, int%n_tot
if (external_link_is_set (int%source(i))) then
int_link => external_link_get_ptr (int%source(i))
index_link = external_link_get_index (int%source(i))
call int%set_momentum (int_link%p(index_link), i)
end if
end do
end subroutine interaction_receive_momenta
@ %def interaction_receive_momenta
@ The inverse operation: Copy momenta back to the interactions linked
to the current one.
<<Interactions: interaction: TBP>>=
procedure :: send_momenta => interaction_send_momenta
<<Interactions: sub interfaces>>=
module subroutine interaction_send_momenta (int)
class(interaction_t), intent(in) :: int
end subroutine interaction_send_momenta
<<Interactions: procedures>>=
module subroutine interaction_send_momenta (int)
class(interaction_t), intent(in) :: int
integer :: i, index_link
type(interaction_t), pointer :: int_link
do i = 1, int%n_tot
if (external_link_is_set (int%source(i))) then
int_link => external_link_get_ptr (int%source(i))
index_link = external_link_get_index (int%source(i))
call int_link%set_momentum (int%p(i), index_link)
end if
end do
end subroutine interaction_send_momenta
@ %def interaction_send_momenta
@ For numerical comparisons: pacify all momenta in an interaction.
<<Interactions: interaction: TBP>>=
procedure :: pacify_momenta => interaction_pacify_momenta
<<Interactions: sub interfaces>>=
module subroutine interaction_pacify_momenta (int, acc)
class(interaction_t), intent(inout) :: int
real(default), intent(in) :: acc
end subroutine interaction_pacify_momenta
<<Interactions: procedures>>=
module subroutine interaction_pacify_momenta (int, acc)
class(interaction_t), intent(inout) :: int
real(default), intent(in) :: acc
integer :: i
do i = 1, int%n_tot
call pacify (int%p(i), acc)
end do
end subroutine interaction_pacify_momenta
@ %def interaction_pacify_momenta
@ For each subtraction entry starting from [[SUB = 0]], we duplicate
the original state matrix entries as is.
<<Interactions: interaction: TBP>>=
procedure :: declare_subtraction => interaction_declare_subtraction
<<Interactions: sub interfaces>>=
module subroutine interaction_declare_subtraction (int, n_sub)
class(interaction_t), intent(inout), target :: int
integer, intent(in) :: n_sub
end subroutine interaction_declare_subtraction
<<Interactions: procedures>>=
module subroutine interaction_declare_subtraction (int, n_sub)
class(interaction_t), intent(inout), target :: int
integer, intent(in) :: n_sub
integer :: i_sub
type(state_iterator_t) :: it
type(quantum_numbers_t), dimension(:), allocatable :: qn
type(state_matrix_t) :: state_matrix
call state_matrix%init (store_values = .true.)
allocate (qn (int%get_state_depth ()))
do i_sub = 0, n_sub
call it%init (int%state_matrix)
do while (it%is_valid ())
qn = it%get_quantum_numbers ()
call qn%set_subtraction_index (i_sub)
call state_matrix%add_state (qn, value = it%get_matrix_element ())
call it%advance ()
end do
end do
call state_matrix%freeze ()
call state_matrix%set_n_sub ()
call int%state_matrix%final ()
int%state_matrix = state_matrix
end subroutine interaction_declare_subtraction
@ %def interaction_declare_subtraction
@
\subsection{Recovering connections}
When creating an evaluator for two interactions, we have to know by
which particles they are connected. The connection indices can be
determined if we have two linked interactions. We assume that
[[int1]] is the source and [[int2]] the target, so the connections of
interest are stored within [[int2]]. A connection is found if either the
source is [[int1]], or the (ultimate)
source of a particle within [[int2]] coincides with the (ultimate) source of a
particle within [[int1]]. The result is an array of
index pairs.
To make things simple, we scan the interaction twice,
once for counting hits, then allocate the array, then scan again and
store the connections.
The connections are scanned for [[int2]], which has sources in [[int1]]. It
may happen that the order of connections is interchanged (crossed). We
require the indices in [[int1]] to be sorted, so we reorder both index arrays
correspondingly before returning them. (After this, the indices in [[int2]]
may be out of order.)
<<Interactions: public>>=
public :: find_connections
<<Interactions: sub interfaces>>=
module subroutine find_connections (int1, int2, n, connection_index)
class(interaction_t), intent(in) :: int1, int2
integer, intent(out) :: n
integer, dimension(:,:), intent(out), allocatable :: connection_index
integer, dimension(:,:), allocatable :: conn_index_tmp
integer, dimension(:), allocatable :: ordering
end subroutine find_connections
<<Interactions: procedures>>=
module subroutine find_connections (int1, int2, n, connection_index)
class(interaction_t), intent(in) :: int1, int2
integer, intent(out) :: n
integer, dimension(:,:), intent(out), allocatable :: connection_index
integer, dimension(:,:), allocatable :: conn_index_tmp
integer, dimension(:), allocatable :: ordering
integer :: i, j, k
type(external_link_t) :: link1, link2
type(interaction_t), pointer :: int_link1, int_link2
n = 0
do i = 1, size (int2%source)
link2 = interaction_get_ultimate_source (int2, i)
if (external_link_is_set (link2)) then
int_link2 => external_link_get_ptr (link2)
if (int_link2%tag == int1%tag) then
n = n + 1
else
k = external_link_get_index (link2)
do j = 1, size (int1%source)
link1 = interaction_get_ultimate_source (int1, j)
if (external_link_is_set (link1)) then
int_link1 => external_link_get_ptr (link1)
if (int_link1%tag == int_link2%tag) then
if (external_link_get_index (link1) == k) &
n = n + 1
end if
end if
end do
end if
end if
end do
allocate (conn_index_tmp (n, 2))
n = 0
do i = 1, size (int2%source)
link2 = interaction_get_ultimate_source (int2, i)
if (external_link_is_set (link2)) then
int_link2 => external_link_get_ptr (link2)
if (int_link2%tag == int1%tag) then
n = n + 1
conn_index_tmp(n,1) = external_link_get_index (int2%source(i))
conn_index_tmp(n,2) = i
else
k = external_link_get_index (link2)
do j = 1, size (int1%source)
link1 = interaction_get_ultimate_source (int1, j)
if (external_link_is_set (link1)) then
int_link1 => external_link_get_ptr (link1)
if (int_link1%tag == int_link2%tag) then
if (external_link_get_index (link1) == k) then
n = n + 1
conn_index_tmp(n,1) = j
conn_index_tmp(n,2) = i
end if
end if
end if
end do
end if
end if
end do
allocate (connection_index (n, 2))
if (n > 1) then
allocate (ordering (n))
ordering = order (conn_index_tmp(:,1))
connection_index = conn_index_tmp(ordering,:)
else
connection_index = conn_index_tmp
end if
end subroutine find_connections
@ %def find_connections
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[interactions_ut.f90]]>>=
<<File header>>
module interactions_ut
use unit_tests
use interactions_uti
<<Standard module head>>
<<Interactions: public test>>
contains
<<Interactions: test driver>>
end module interactions_ut
@ %def interactions_ut
@
<<[[interactions_uti.f90]]>>=
<<File header>>
module interactions_uti
<<Use kinds>>
use lorentz
use flavors
use colors
use helicities
use quantum_numbers
use state_matrices
use interactions
<<Standard module head>>
<<Interactions: test declarations>>
contains
<<Interactions: tests>>
end module interactions_uti
@ %def interactions_ut
@ API: driver for the unit tests below.
<<Interactions: public test>>=
public :: interaction_test
<<Interactions: test driver>>=
subroutine interaction_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Interactions: execute tests>>
end subroutine interaction_test
@ %def interaction_test
@ Generate an interaction of a polarized virtual photon and a colored
quark which may be either up or down. Remove the quark polarization.
Generate another interaction for the quark radiating a photon and link
this to the first interation. The radiation ignores polarization;
transfer this information to the first interaction to simplify it.
Then, transfer the momentum to the radiating quark and perform a
splitting.
<<Interactions: execute tests>>=
call test (interaction_1, "interaction_1", &
"check interaction setup", &
u, results)
<<Interactions: test declarations>>=
public :: interaction_1
<<Interactions: tests>>=
subroutine interaction_1 (u)
integer, intent(in) :: u
type(interaction_t), target :: int, rad
type(vector4_t), dimension(3) :: p
type(quantum_numbers_mask_t), dimension(3) :: mask
p(2) = vector4_moving (500._default, 500._default, 1)
p(3) = vector4_moving (500._default,-500._default, 1)
p(1) = p(2) + p(3)
write (u, "(A)") "* Test output: interaction"
write (u, "(A)") "* Purpose: check routines for interactions"
write (u, "(A)")
call int%basic_init (1, 0, 2, set_relations=.true., &
store_values = .true. )
call int_set (int, 1, -1, 1, 1, &
cmplx (0.3_default, 0.1_default, kind=default))
call int_set (int, 1, -1,-1, 1, &
cmplx (0.5_default,-0.7_default, kind=default))
call int_set (int, 1, 1, 1, 1, &
cmplx (0.1_default, 0._default, kind=default))
call int_set (int, -1, 1, -1, 2, &
cmplx (0.4_default, -0.1_default, kind=default))
call int_set (int, 1, 1, 1, 2, &
cmplx (0.2_default, 0._default, kind=default))
call int%freeze ()
call int%set_momenta (p)
mask = quantum_numbers_mask (.false.,.false., [.true.,.true.,.true.])
call rad%basic_init (1, 0, 2, &
mask=mask, set_relations=.true., store_values = .true.)
call rad_set (1)
call rad_set (2)
call rad%set_source_link (1, int, 2)
call rad%exchange_mask ()
call rad%receive_momenta ()
p(1) = rad%get_momentum (1)
p(2) = 0.4_default * p(1)
p(3) = p(1) - p(2)
call rad%set_momenta (p(2:3), outgoing=.true.)
call int%freeze ()
call rad%freeze ()
call rad%set_matrix_element &
(cmplx (0._default, 0._default, kind=default))
call int%basic_write (u)
write (u, "(A)")
call rad%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call int%final ()
call rad%final ()
write (u, "(A)")
write (u, "(A)") "* Test interaction_1: successful."
contains
subroutine int_set (int, h1, h2, hq, q, val)
type(interaction_t), target, intent(inout) :: int
integer, intent(in) :: h1, h2, hq, q
type(flavor_t), dimension(3) :: flv
type(color_t), dimension(3) :: col
type(helicity_t), dimension(3) :: hel
type(quantum_numbers_t), dimension(3) :: qn
complex(default), intent(in) :: val
call flv%init ([21, q, -q])
call col(2)%init_col_acl (5, 0)
call col(3)%init_col_acl (0, 5)
call hel%init ([h1, hq, -hq], [h2, hq, -hq])
call qn%init (flv, col, hel)
call int%add_state (qn)
call int%set_matrix_element (val)
end subroutine int_set
subroutine rad_set (q)
integer, intent(in) :: q
type(flavor_t), dimension(3) :: flv
type(quantum_numbers_t), dimension(3) :: qn
call flv%init ([ q, q, 21 ])
call qn%init (flv)
call rad%add_state (qn)
end subroutine rad_set
end subroutine interaction_1
@ %def interaction_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Matrix element evaluation}
The [[evaluator_t]] type is an extension of the [[interaction_t]]
type. It represents either a density matrix as the square of a
transition matrix element, or the product of two density matrices.
Usually, some quantum numbers are summed over in the result.
The [[interaction_t]] subobject represents a multi-particle
interaction with incoming, virtual, and outgoing particles and the
associated (not necessarily diagonal) density matrix of quantum
state. When the evaluator is initialized, this interaction is
constructed from the input interaction(s).
In addition, the initialization process sets up a multiplication
table. For each matrix element of the result, it states which matrix
elements are to be taken from the input interaction(s), multiplied
(optionally, with an additional weight factor) and summed over.
Eventually, to a processes we associate a chain of evaluators which
are to be evaluated sequentially. The physical event and its matrix
element value(s) can be extracted from the last evaluator in such a
chain.
Evaluators are constructed only once (as long as this is possible)
during an initialization step. Then, for each event, momenta
are computed and transferred among evaluators using the links within
the interaction subobject. The multiplication tables enable fast
evaluation of the result without looking at quantum numbers anymore.
<<[[evaluators.f90]]>>=
<<File header>>
module evaluators
<<Use kinds>>
<<Use strings>>
use flavors
use colors
use helicities
use quantum_numbers
use state_matrices
use interactions
<<Standard module head>>
<<Evaluators: public>>
<<Evaluators: parameters>>
<<Evaluators: types>>
<<Evaluators: interfaces>>
interface
<<Evaluators: sub interfaces>>
end interface
end module evaluators
@ %def evaluators
@
<<[[evaluators_sub.f90]]>>=
<<File header>>
submodule (evaluators) evaluators_s
use io_units
use format_defs, only: FMT_19
use physics_defs, only: n_beams_rescaled
use diagnostics
use lorentz
implicit none
contains
<<Evaluators: procedures>>
end submodule evaluators_s
@ %def evaluators_s
@
\subsection{Array of pairings}
The evaluator contains an array of [[pairing_array]] objects. This
makes up the multiplication table.
Each pairing array contains two lists of matrix element indices and a
list of numerical factors. The matrix element indices correspond to
the input interactions. The corresponding matrix elements are to be
multiplied and optionally multiplied by a factor. The results are
summed over to yield one specific matrix element of the result
evaluator.
<<Evaluators: types>>=
type :: pairing_array_t
integer, dimension(:), allocatable :: i1, i2
complex(default), dimension(:), allocatable :: factor
end type pairing_array_t
@ %def pairing_array_t
<<Evaluators: sub interfaces>>=
elemental module subroutine pairing_array_init (pa, n, has_i2, has_factor)
type(pairing_array_t), intent(out) :: pa
integer, intent(in) :: n
logical, intent(in) :: has_i2, has_factor
end subroutine pairing_array_init
<<Evaluators: procedures>>=
elemental module subroutine pairing_array_init (pa, n, has_i2, has_factor)
type(pairing_array_t), intent(out) :: pa
integer, intent(in) :: n
logical, intent(in) :: has_i2, has_factor
allocate (pa%i1 (n))
if (has_i2) allocate (pa%i2 (n))
if (has_factor) allocate (pa%factor (n))
end subroutine pairing_array_init
@ %def pairing_array_init
@
<<Evaluators: public>>=
public :: pairing_array_write
<<Evaluators: sub interfaces>>=
module subroutine pairing_array_write (pa, unit)
type(pairing_array_t), intent(in) :: pa
integer, intent(in), optional :: unit
end subroutine pairing_array_write
<<Evaluators: procedures>>=
module subroutine pairing_array_write (pa, unit)
type(pairing_array_t), intent(in) :: pa
integer, intent(in), optional :: unit
integer :: i, u
u = given_output_unit (unit); if (u < 0) return
write (u, "(A)", advance = "no") "["
if (allocated (pa%i1)) then
write (u, "(I0,A)", advance = "no") pa%i1, ","
else
write (u, "(A)", advance = "no") "x,"
end if
if (allocated (pa%i2)) then
write (u, "(I0,A)", advance = "no") pa%i1, ","
else
write (u, "(A)", advance = "no") "x,"
end if
write (u, "(A)", advance = "no") "]"
if (allocated (pa%factor)) then
write (u, "(A,F5.4,A,F5.4,A)") ";(", &
real(pa%factor), ",", aimag(pa%factor), ")]"
else
write (u, "(A)") ""
end if
end subroutine pairing_array_write
@ %def pairing_array_write
@
\subsection{The evaluator type}
Possible variants of evaluators:
<<Evaluators: parameters>>=
integer, parameter :: &
EVAL_UNDEFINED = 0, &
EVAL_PRODUCT = 1, &
EVAL_SQUARED_FLOWS = 2, &
EVAL_SQUARE_WITH_COLOR_FACTORS = 3, &
EVAL_COLOR_CONTRACTION = 4, &
EVAL_IDENTITY = 5, &
EVAL_QN_SUM = 6
@ %def EVAL_PRODUCT EVAL_SQUARED_FLOWS EVAL_SQUARE_WITH_COLOR_FACTORS
@ %def EVAL_COLOR_CONTRACTION EVAL_QN_SUM
@ The evaluator type contains the result interaction and an array of
pairing lists, one for each matrix element in the result interaction.
<<Evaluators: public>>=
public :: evaluator_t
<<Evaluators: types>>=
type, extends (interaction_t) :: evaluator_t
private
integer :: type = EVAL_UNDEFINED
class(interaction_t), pointer :: int_in1 => null ()
class(interaction_t), pointer :: int_in2 => null ()
type(pairing_array_t), dimension(:), allocatable :: pairing_array
contains
<<Evaluators: evaluator: TBP>>
end type evaluator_t
@ %def evaluator_t
@ Output.
<<Evaluators: evaluator: TBP>>=
procedure :: write => evaluator_write
<<Evaluators: sub interfaces>>=
module subroutine evaluator_write (eval, unit, &
verbose, show_momentum_sum, show_mass, show_state, show_table, &
col_verbose, testflag)
class(evaluator_t), intent(in) :: eval
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
logical, intent(in), optional :: show_state, show_table, col_verbose
logical, intent(in), optional :: testflag
end subroutine evaluator_write
<<Evaluators: procedures>>=
module subroutine evaluator_write (eval, unit, &
verbose, show_momentum_sum, show_mass, show_state, show_table, &
col_verbose, testflag)
class(evaluator_t), intent(in) :: eval
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
logical, intent(in), optional :: show_state, show_table, col_verbose
logical, intent(in), optional :: testflag
logical :: conjugate, square, show_tab
integer :: u
u = given_output_unit (unit); if (u < 0) return
show_tab = .true.; if (present (show_table)) show_tab = .false.
call eval%basic_write &
(unit, verbose, show_momentum_sum, show_mass, &
show_state, col_verbose, testflag)
if (show_tab) then
write (u, "(1x,A)") "Matrix-element multiplication"
write (u, "(2x,A)", advance="no") "Input interaction 1:"
if (associated (eval%int_in1)) then
write (u, "(1x,I0)") eval%int_in1%get_tag ()
else
write (u, "(A)") " [undefined]"
end if
write (u, "(2x,A)", advance="no") "Input interaction 2:"
if (associated (eval%int_in2)) then
write (u, "(1x,I0)") eval%int_in2%get_tag ()
else
write (u, "(A)") " [undefined]"
end if
select case (eval%type)
case (EVAL_SQUARED_FLOWS, EVAL_SQUARE_WITH_COLOR_FACTORS)
conjugate = .true.
square = .true.
case (EVAL_IDENTITY)
write (u, "(1X,A)") "Identity evaluator, pairing array unused"
return
case default
conjugate = .false.
square = .false.
end select
call eval%write_pairing_array (conjugate, square, u)
end if
end subroutine evaluator_write
@ %def evaluator_write
@
<<Evaluators: evaluator: TBP>>=
procedure :: write_pairing_array => evaluator_write_pairing_array
<<Evaluators: sub interfaces>>=
module subroutine evaluator_write_pairing_array (eval, conjugate, square, unit)
class(evaluator_t), intent(in) :: eval
logical, intent(in) :: conjugate, square
integer, intent(in), optional :: unit
end subroutine evaluator_write_pairing_array
<<Evaluators: procedures>>=
module subroutine evaluator_write_pairing_array (eval, conjugate, square, unit)
class(evaluator_t), intent(in) :: eval
logical, intent(in) :: conjugate, square
integer, intent(in), optional :: unit
integer :: u, i, j
u = given_output_unit (unit); if (u < 0) return
if (allocated (eval%pairing_array)) then
do i = 1, size (eval%pairing_array)
write (u, "(2x,A,I0,A)") "ME(", i, ") = "
do j = 1, size (eval%pairing_array(i)%i1)
write (u, "(4x,A)", advance="no") "+"
if (allocated (eval%pairing_array(i)%i2)) then
write (u, "(1x,A,I0,A)", advance="no") &
"ME1(", eval%pairing_array(i)%i1(j), ")"
if (conjugate) then
write (u, "(A)", advance="no") "* x"
else
write (u, "(A)", advance="no") " x"
end if
write (u, "(1x,A,I0,A)", advance="no") &
"ME2(", eval%pairing_array(i)%i2(j), ")"
else if (square) then
write (u, "(1x,A)", advance="no") "|"
write (u, "(A,I0,A)", advance="no") &
"ME1(", eval%pairing_array(i)%i1(j), ")"
write (u, "(A)", advance="no") "|^2"
else
write (u, "(1x,A,I0,A)", advance="no") &
"ME1(", eval%pairing_array(i)%i1(j), ")"
end if
if (allocated (eval%pairing_array(i)%factor)) then
write (u, "(1x,A)", advance="no") "x"
write (u, "(1x,'('," // FMT_19 // ",','," // FMT_19 // &
",')')") eval%pairing_array(i)%factor(j)
else
write (u, *)
end if
end do
end do
end if
end subroutine evaluator_write_pairing_array
@ %def evaluator_write_pairing_array
@ Assignment: Deep copy of the interaction component.
<<Evaluators: public>>=
public :: assignment(=)
<<Evaluators: interfaces>>=
interface assignment(=)
module procedure evaluator_assign
end interface
<<Evaluators: sub interfaces>>=
module subroutine evaluator_assign (eval_out, eval_in)
type(evaluator_t), intent(out) :: eval_out
type(evaluator_t), intent(in) :: eval_in
end subroutine evaluator_assign
<<Evaluators: procedures>>=
module subroutine evaluator_assign (eval_out, eval_in)
type(evaluator_t), intent(out) :: eval_out
type(evaluator_t), intent(in) :: eval_in
eval_out%type = eval_in%type
eval_out%int_in1 => eval_in%int_in1
eval_out%int_in2 => eval_in%int_in2
eval_out%interaction_t = eval_in%interaction_t
if (allocated (eval_in%pairing_array)) then
allocate (eval_out%pairing_array (size (eval_in%pairing_array)))
eval_out%pairing_array = eval_in%pairing_array
end if
end subroutine evaluator_assign
@ %def evaluator_assign
@
\subsection{Auxiliary structures for evaluator creation}
Creating an evaluator that properly handles all quantum numbers requires some
bookkeeping. In this section, we define several auxiliary types and methods
that organize and simplify this task. More structures are defined within the
specific initializers (as local types and internal subroutines).
These types are currently implemented in a partial object-oriented way: We
define some basic methods for initialization etc.\ here, but the evaluator
routines below do access their internals as well. This simplifies some things
such as index addressing using array slices, at the expense of losing some
clarity.
\subsubsection{Index mapping}
Index mapping are abundant when constructing an evaluator. To have arrays of
index mappings, we define this:
<<Evaluators: types>>=
type :: index_map_t
integer, dimension(:), allocatable :: entry
end type index_map_t
@ %def index_map_t
<<Evaluators: sub interfaces>>=
elemental module subroutine index_map_init (map, n)
type(index_map_t), intent(out) :: map
integer, intent(in) :: n
end subroutine index_map_init
<<Evaluators: procedures>>=
elemental module subroutine index_map_init (map, n)
type(index_map_t), intent(out) :: map
integer, intent(in) :: n
allocate (map%entry (n))
map%entry = 0
end subroutine index_map_init
@ %def index_map_init
<<Evaluators: procedures>>=
function index_map_exists (map) result (flag)
logical :: flag
type(index_map_t), intent(in) :: map
flag = allocated (map%entry)
end function index_map_exists
@ %def index_map_exists
<<Evaluators: interfaces>>=
interface size
module procedure index_map_size
end interface
@ %def size
<<Evaluators: sub interfaces>>=
module function index_map_size (map) result (s)
integer :: s
type(index_map_t), intent(in) :: map
end function index_map_size
<<Evaluators: procedures>>=
module function index_map_size (map) result (s)
integer :: s
type(index_map_t), intent(in) :: map
if (allocated (map%entry)) then
s = size (map%entry)
else
s = 0
end if
end function index_map_size
@ %def index_map_size
<<Evaluators: interfaces>>=
interface assignment(=)
module procedure index_map_assign_int
module procedure index_map_assign_array
end interface
@ %def =
<<Evaluators: sub interfaces>>=
elemental module subroutine index_map_assign_int (map, ival)
type(index_map_t), intent(inout) :: map
integer, intent(in) :: ival
end subroutine index_map_assign_int
module subroutine index_map_assign_array (map, array)
type(index_map_t), intent(inout) :: map
integer, dimension(:), intent(in) :: array
end subroutine index_map_assign_array
<<Evaluators: procedures>>=
elemental module subroutine index_map_assign_int (map, ival)
type(index_map_t), intent(inout) :: map
integer, intent(in) :: ival
map%entry = ival
end subroutine index_map_assign_int
module subroutine index_map_assign_array (map, array)
type(index_map_t), intent(inout) :: map
integer, dimension(:), intent(in) :: array
map%entry = array
end subroutine index_map_assign_array
@ %def index_map_assign_int index_map_assign_array
<<Evaluators: sub interfaces>>=
elemental module subroutine index_map_set_entry (map, i, ival)
type(index_map_t), intent(inout) :: map
integer, intent(in) :: i
integer, intent(in) :: ival
end subroutine index_map_set_entry
<<Evaluators: procedures>>=
elemental module subroutine index_map_set_entry (map, i, ival)
type(index_map_t), intent(inout) :: map
integer, intent(in) :: i
integer, intent(in) :: ival
map%entry(i) = ival
end subroutine index_map_set_entry
@ %def index_map_set_entry
<<Evaluators: sub interfaces>>=
elemental module function index_map_get_entry (map, i) result (ival)
integer :: ival
type(index_map_t), intent(in) :: map
integer, intent(in) :: i
end function index_map_get_entry
<<Evaluators: procedures>>=
elemental module function index_map_get_entry (map, i) result (ival)
integer :: ival
type(index_map_t), intent(in) :: map
integer, intent(in) :: i
ival = map%entry(i)
end function index_map_get_entry
@ %def index_map_get_entry
@
\subsubsection{Index mapping (two-dimensional)}
This is a variant with a square matrix instead of an array.
<<Evaluators: types>>=
type :: index_map2_t
integer :: s = 0
integer, dimension(:,:), allocatable :: entry
end type index_map2_t
@ %def index_map2_t
<<Evaluators: procedures>>=
elemental subroutine index_map2_init (map, n)
type(index_map2_t), intent(out) :: map
integer, intent(in) :: n
map%s = n
allocate (map%entry (n, n))
end subroutine index_map2_init
@ %def index_map2_init
<<Evaluators: procedures>>=
function index_map2_exists (map) result (flag)
logical :: flag
type(index_map2_t), intent(in) :: map
flag = allocated (map%entry)
end function index_map2_exists
@ %def index_map2_exists
<<Evaluators: interfaces>>=
interface size
module procedure index_map2_size
end interface
@ %def size
<<Evaluators: sub interfaces>>=
module function index_map2_size (map) result (s)
integer :: s
type(index_map2_t), intent(in) :: map
end function index_map2_size
<<Evaluators: procedures>>=
module function index_map2_size (map) result (s)
integer :: s
type(index_map2_t), intent(in) :: map
s = map%s
end function index_map2_size
@ %def index_map2_size
<<Evaluators: interfaces>>=
interface assignment(=)
module procedure index_map2_assign_int
end interface
@ %def =
<<Evaluators: sub interfaces>>=
elemental module subroutine index_map2_assign_int (map, ival)
type(index_map2_t), intent(inout) :: map
integer, intent(in) :: ival
end subroutine index_map2_assign_int
<<Evaluators: procedures>>=
elemental module subroutine index_map2_assign_int (map, ival)
type(index_map2_t), intent(inout) :: map
integer, intent(in) :: ival
map%entry = ival
end subroutine index_map2_assign_int
@ %def index_map2_assign_int
<<Evaluators: procedures>>=
elemental subroutine index_map2_set_entry (map, i, j, ival)
type(index_map2_t), intent(inout) :: map
integer, intent(in) :: i, j
integer, intent(in) :: ival
map%entry(i,j) = ival
end subroutine index_map2_set_entry
@ %def index_map2_set_entry
<<Evaluators: procedures>>=
elemental function index_map2_get_entry (map, i, j) result (ival)
integer :: ival
type(index_map2_t), intent(in) :: map
integer, intent(in) :: i, j
ival = map%entry(i,j)
end function index_map2_get_entry
@ %def index_map2_get_entry
@
\subsubsection{Auxiliary structures: particle mask}
This is a simple container of a logical array.
<<Evaluators: types>>=
type :: prt_mask_t
logical, dimension(:), allocatable :: entry
end type prt_mask_t
@ %def prt_mask_t
<<Evaluators: procedures>>=
subroutine prt_mask_init (mask, n)
type(prt_mask_t), intent(out) :: mask
integer, intent(in) :: n
allocate (mask%entry (n))
end subroutine prt_mask_init
@ %def prt_mask_init
<<Evaluators: interfaces>>=
interface size
module procedure prt_mask_size
end interface
@ %def size
<<Evaluators: sub interfaces>>=
module function prt_mask_size (mask) result (s)
integer :: s
type(prt_mask_t), intent(in) :: mask
end function prt_mask_size
<<Evaluators: procedures>>=
module function prt_mask_size (mask) result (s)
integer :: s
type(prt_mask_t), intent(in) :: mask
s = size (mask%entry)
end function prt_mask_size
@ %def prt_mask_size
@
\subsubsection{Quantum number containers}
Trivial transparent containers:
<<Evaluators: types>>=
type :: qn_list_t
type(quantum_numbers_t), dimension(:,:), allocatable :: qn
end type qn_list_t
type :: qn_mask_array_t
type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
end type qn_mask_array_t
@ %def qn_list_t qn_mask_array_t
@
\subsubsection{Auxiliary structures: connection entries}
This type is used as intermediate storage when computing the product of two
evaluators or the square of an evaluator. The quantum-number array [[qn]]
corresponds to the particles common to both interactions, but irrelevant
quantum numbers (color) masked out. The index arrays [[index_in]] determine
the entries in the input interactions that contribute to this connection.
[[n_index]] is the size of these arrays, and [[count]] is used while filling
the entries. Finally, the quantum-number arrays [[qn_in_list]] are the actual
entries in the input interaction that contribute. In the product case, they
exclude the connected quantum numbers.
Each evaluator has its own [[connection_table]] which contains an array of
[[connection_entry]] objects, but also has stuff that specifically applies to
the evaluator type. Hence, we do not generalize the [[connection_table_t]]
type.
The filling procedure [[connection_entry_add_state]] is specific to the
various evaluator types.
<<Evaluators: types>>=
type :: connection_entry_t
type(quantum_numbers_t), dimension(:), allocatable :: qn_conn
integer, dimension(:), allocatable :: n_index
integer, dimension(:), allocatable :: count
type(index_map_t), dimension(:), allocatable :: index_in
type(qn_list_t), dimension(:), allocatable :: qn_in_list
end type connection_entry_t
@ %def connection_entry_t
<<Evaluators: procedures>>=
subroutine connection_entry_init &
(entry, n_count, n_map, qn_conn, count, n_rest)
type(connection_entry_t), intent(out) :: entry
integer, intent(in) :: n_count, n_map
type(quantum_numbers_t), dimension(:), intent(in) :: qn_conn
integer, dimension(n_count), intent(in) :: count
integer, dimension(n_count), intent(in) :: n_rest
integer :: i
allocate (entry%qn_conn (size (qn_conn)))
allocate (entry%n_index (n_count))
allocate (entry%count (n_count))
allocate (entry%index_in (n_map))
allocate (entry%qn_in_list (n_count))
entry%qn_conn = qn_conn
entry%n_index = count
entry%count = 0
if (size (entry%index_in) == size (count)) then
call index_map_init (entry%index_in, count)
else
call index_map_init (entry%index_in, count(1))
end if
do i = 1, n_count
allocate (entry%qn_in_list(i)%qn (n_rest(i), count(i)))
end do
end subroutine connection_entry_init
@ %def connection_entry_init
<<Evaluators: procedures>>=
subroutine connection_entry_write (entry, unit)
type(connection_entry_t), intent(in) :: entry
integer, intent(in), optional :: unit
integer :: i, j
integer :: u
u = given_output_unit (unit)
call quantum_numbers_write (entry%qn_conn, unit)
write (u, *)
do i = 1, size (entry%n_index)
write (u, *) "Input interaction", i
do j = 1, entry%n_index(i)
if (size (entry%n_index) == size (entry%index_in)) then
write (u, "(2x,I0,4x,I0,2x)", advance = "no") &
j, index_map_get_entry (entry%index_in(i), j)
else
write (u, "(2x,I0,4x,I0,2x,I0,2x)", advance = "no") &
j, index_map_get_entry (entry%index_in(1), j), &
index_map_get_entry (entry%index_in(2), j)
end if
call quantum_numbers_write (entry%qn_in_list(i)%qn(:,j), unit)
write (u, *)
end do
end do
end subroutine connection_entry_write
@ %def connection_entry_write
@ These are the different connection tables for the three different
cases of evaluators for matrix elements, squared diagonal and
non-diagonal matrix elements, respectively.
<<Evaluators: types>>=
type :: connection_table_t
integer :: n_conn = 0
integer, dimension(2) :: n_rest = 0
integer :: n_tot = 0
integer :: n_me_conn = 0
type(state_matrix_t) :: state
type(index_map_t), dimension(:), allocatable :: index_conn
type(connection_entry_t), dimension(:), allocatable :: entry
type(index_map_t) :: index_result
end type connection_table_t
type :: connection_table_diag_t
integer :: n_tot = 0
integer :: n_me_conn = 0
type(state_matrix_t) :: state
type(index_map_t) :: index_conn
type(connection_entry_t), dimension(:), allocatable :: entry
type(index_map_t) :: index_result
end type connection_table_diag_t
type :: connection_table_nondiag_t
integer :: n_tot = 0
integer :: n_me_conn = 0
type(state_matrix_t) :: state
type(index_map2_t) :: index_conn
type(connection_entry_t), dimension(:), allocatable :: entry
type(index_map_t) :: index_result
end type connection_table_nondiag_t
-@ %def connection_table_t
+@ %def connection_table_t
@ %def connection_table_diag_t
@
\subsubsection{Color handling}
For managing color-factor computation, we introduce this local type. The
[[index]] is the index in the color table that corresponds to a given matrix
element index in the input interaction. The [[col]] array stores the color
assignments in rows. The [[factor]] array associates a complex number with
each pair of arrays in the color table. The [[factor_is_known]] array reveals
whether a given factor is known already or still has to be computed.
<<Evaluators: types>>=
type :: color_table_t
integer, dimension(:), allocatable :: index
type(color_t), dimension(:,:), allocatable :: col
logical, dimension(:,:), allocatable :: factor_is_known
complex(default), dimension(:,:), allocatable :: factor
end type color_table_t
@ %def color_table_t
@ This is the initializer. We extract the color states from the given state
matrices, establish index mappings between the two states (implemented by the
array [[me_index]]), make an array of color states, and initialize the
color-factor table. The latter is two-dimensional (includes interference) and
not yet filled.
<<Evaluators: procedures>>=
subroutine color_table_init (color_table, state, n_tot)
type(color_table_t), intent(out) :: color_table
type(state_matrix_t), intent(in) :: state
integer, intent(in) :: n_tot
type(state_iterator_t) :: it
type(quantum_numbers_t), dimension(:), allocatable :: qn
type(state_matrix_t) :: state_col
integer :: index, n_col_state
allocate (color_table%index (state%get_n_matrix_elements ()))
color_table%index = 0
allocate (qn (n_tot))
call state_col%init ()
call it%init (state)
do while (it%is_valid ())
index = it%get_me_index ()
call qn%init (col = it%get_color ())
call state_col%add_state (qn, me_index = color_table%index(index))
call it%advance ()
end do
n_col_state = state_col%get_n_matrix_elements ()
allocate (color_table%col (n_tot, n_col_state))
call it%init (state_col)
do while (it%is_valid ())
index = it%get_me_index ()
color_table%col(:,index) = it%get_color ()
call it%advance ()
end do
call state_col%final ()
allocate (color_table%factor_is_known (n_col_state, n_col_state))
allocate (color_table%factor (n_col_state, n_col_state))
color_table%factor_is_known = .false.
end subroutine color_table_init
@ %def color_table_init
@ Output (debugging use):
<<Evaluators: procedures>>=
subroutine color_table_write (color_table, unit)
type(color_table_t), intent(in) :: color_table
integer, intent(in), optional :: unit
integer :: i, j
integer :: u
u = given_output_unit (unit)
write (u, *) "Color table:"
if (allocated (color_table%index)) then
write (u, *) " Index mapping state => color table:"
do i = 1, size (color_table%index)
write (u, "(3x,I0,2x,I0,2x)") i, color_table%index(i)
end do
write (u, *) " Color table:"
do i = 1, size (color_table%col, 2)
write (u, "(3x,I0,2x)", advance = "no") i
call color_write (color_table%col(:,i), unit)
write (u, *)
end do
write (u, *) " Defined color factors:"
do i = 1, size (color_table%factor, 1)
do j = 1, size (color_table%factor, 2)
if (color_table%factor_is_known(i,j)) then
write (u, *) i, j, color_table%factor(i,j)
end if
end do
end do
end if
end subroutine color_table_write
@ %def color_table_write
@ This subroutine sets color factors, based on information from the hard
matrix element: the list of pairs of color-flow indices (in the basis of the
matrix element code), the list of corresponding factors, and the list of
mappings from the matrix element index in the input interaction to the
color-flow index in the hard matrix element object.
We first determine the mapping of color-flow indices from the hard matrix
element code to the current color table. The mapping could be nontrivial
because the latter is derived from iterating over a state matrix, which may
return states in non-canonical order. The translation table can be determined
because we have, for the complete state matrix, both the mapping to the hard
interaction (the input [[col_index_hi]]) and the mapping to the current
color table (the component [[color_table%index]]).
Once this mapping is known, we scan the list of index pairs
[[color_flow_index]] and translate them to valid color-table index pairs. For
this pair, the color factor is set using the corresponding entry in the list
[[col_factor]].
<<Evaluators: procedures>>=
subroutine color_table_set_color_factors (color_table, &
col_flow_index, col_factor, col_index_hi)
type(color_table_t), intent(inout) :: color_table
integer, dimension(:,:), intent(in) :: col_flow_index
complex(default), dimension(:), intent(in) :: col_factor
integer, dimension(:), intent(in) :: col_index_hi
integer, dimension(:), allocatable :: hi_to_ct
integer :: n_cflow
integer :: hi_index, me_index, ct_index, cf_index
integer, dimension(2) :: hi_index_pair, ct_index_pair
n_cflow = size (col_index_hi)
if (size (color_table%index) /= n_cflow) &
call msg_bug ("Mismatch between hard matrix element and color table")
allocate (hi_to_ct (n_cflow))
do me_index = 1, size (color_table%index)
ct_index = color_table%index(me_index)
hi_index = col_index_hi(me_index)
hi_to_ct(hi_index) = ct_index
end do
do cf_index = 1, size (col_flow_index, 2)
hi_index_pair = col_flow_index(:,cf_index)
ct_index_pair = hi_to_ct(hi_index_pair)
color_table%factor(ct_index_pair(1), ct_index_pair(2)) = &
col_factor(cf_index)
color_table%factor_is_known(ct_index_pair(1), ct_index_pair(2)) = .true.
end do
end subroutine color_table_set_color_factors
@ %def color_table_set_color_factors
@ This function returns a color factor, given two indices which point to the
matrix elements of the initial state matrix. Internally, we can map them to
the corresponding indices in the color table. As a side effect, we store the
color factor in the color table for later lookup. (I.e., this function is
impure.)
<<Evaluators: procedures>>=
function color_table_get_color_factor (color_table, index1, index2, nc) &
result (factor)
real(default) :: factor
type(color_table_t), intent(inout) :: color_table
integer, intent(in) :: index1, index2
integer, intent(in), optional :: nc
integer :: i1, i2
i1 = color_table%index(index1)
i2 = color_table%index(index2)
if (color_table%factor_is_known(i1,i2)) then
factor = real(color_table%factor(i1,i2), kind=default)
else
factor = compute_color_factor &
(color_table%col(:,i1), color_table%col(:,i2), nc)
color_table%factor(i1,i2) = factor
color_table%factor_is_known(i1,i2) = .true.
end if
end function color_table_get_color_factor
@ %def color_table_get_color_factor
@
\subsection{Creating an evaluator: Matrix multiplication}
The evaluator for matrix multiplication is the most complicated
variant.
The initializer takes two input interactions and constructs the result
evaluator, which consists of the interaction and the multiplication
table for the product (or convolution) of the two. Normally, the
input interactions are connected by one or more common particles
(e.g., decay, structure function convolution).
In the result interaction, quantum numbers of the connections can be
summed over. This is determined by the [[qn_mask_conn]] argument.
The [[qn_mask_rest]] argument is its analog for the other particles
within the result interaction. (E.g., for the trace of the state
matrix, all quantum numbers are summed over.)
Finally, the
[[connections_are_resonant]] argument tells whether the connecting
particles should be marked as resonant in the final event record. If true,
this also implies that the second interaction is not the hard process, so any
corresponding tags should be removed from the outgoing particles.
This applies to decays.
The algorithm consists of the following steps:
\begin{enumerate}
\item
[[find_connections]]: Find the particles which are connected, i.e.,
common to both input interactions. Either they are directly linked,
or both are linked to a common source.
\item
[[compute_index_bounds_and_mappings]]: Compute the mappings of
particle indices from the input interactions to the result
interaction. There is a separate mapping for the connected
particles.
\item
[[accumulate_connected_states]]: Create an auxiliary state matrix
which lists the possible quantum numbers for the connected
particles. When building this matrix, count the number of times
each assignment is contained in any of the input states and, for
each of the input states, record the index of the matrix element
within the new state matrix. For the connected particles, reassign
color indices such that no color state is present twice in different
color-index assignment. Note that helicity assignments of the
connected state can be (and will be) off-diagonal, so no spin
correlations are lost in decays.
Do this for both input interactions.
\item
[[allocate_connection_entries]]: Allocate a table of connections.
Each table row corresponds to one state in the auxiliary matrix, and
to multiple states of the input interactions. It collects all
states of the unconnected particles in the two input interactions
that are associated with the particular state (quantum-number
assignment) of the connected particles.
\item
[[fill_connection_table]]: Fill the table of connections by scanning
both input interactions. When copying states, reassign color
indices for the unconnected particles such that they match between
all involved particle sets (interaction 1, interaction 2, and
connected particles).
\item
[[make_product_interaction]]: Scan the table of connections we have
just built. For each entry, construct all possible pairs of states
of the unconnected particles and combine them with the specific
connected-particle state. This is a possible quantum-number
assignment of the result interaction. Now mask all quantum numbers
that should be summed over, and append this to the result state
matrix. Record the matrix element index of the result. We now have
the result interaction.
\item
[[make_pairing_array]]: First allocate the pairing array with the
number of entries of the result interaction. Then scan the table of
connections again. For each entry, record the indices of the matrix
elements which have to be multiplied and summed over in order to
compute this particular matrix element. This makes up the
multiplication table.
\item
[[record_links]]: Transfer all source pointers from the input
interactions to the result interaction. Do the same for the
internal parent-child relations and resonance assignments. For the
connected particles, make up appropriate additional parent-child
relations. This allows for fetching momenta from other interactions
when a new event is filled, and to reconstruct the event history
when the event is analyzed.
\end{enumerate}
After all this is done, for each event, we just have to evaluate the
pairing arrays (multiplication tables) in order to compute the result
matrix elements in their proper positions. The quantum-number
assignments remain fixed from now on.
<<Evaluators: evaluator: TBP>>=
procedure :: init_product => evaluator_init_product
<<Evaluators: sub interfaces>>=
module subroutine evaluator_init_product &
(eval, int_in1, int_in2, qn_mask_conn, qn_filter_conn, qn_mask_rest, &
connections_are_resonant, ignore_sub_for_qn)
class(evaluator_t), intent(out), target :: eval
class(interaction_t), intent(in), target :: int_in1, int_in2
type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn
type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest
logical, intent(in), optional :: connections_are_resonant
logical, intent(in), optional :: ignore_sub_for_qn
end subroutine evaluator_init_product
<<Evaluators: procedures>>=
module subroutine evaluator_init_product &
(eval, int_in1, int_in2, qn_mask_conn, qn_filter_conn, qn_mask_rest, &
connections_are_resonant, ignore_sub_for_qn)
class(evaluator_t), intent(out), target :: eval
class(interaction_t), intent(in), target :: int_in1, int_in2
type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn
type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest
logical, intent(in), optional :: connections_are_resonant
logical, intent(in), optional :: ignore_sub_for_qn
type(qn_mask_array_t), dimension(2) :: qn_mask_in
type(state_matrix_t), pointer :: state_in1, state_in2
type(connection_table_t) :: connection_table
integer :: n_in, n_vir, n_out, n_tot
integer, dimension(2) :: n_rest
integer :: n_conn
integer, dimension(:,:), allocatable :: connection_index
type(index_map_t), dimension(2) :: prt_map_in
type(index_map_t) :: prt_map_conn
type(prt_mask_t), dimension(2) :: prt_is_connected
type(quantum_numbers_mask_t), dimension(:), allocatable :: &
qn_mask_conn_initial, int_in1_mask, int_in2_mask
integer :: i
eval%type = EVAL_PRODUCT
eval%int_in1 => int_in1
eval%int_in2 => int_in2
state_in1 => int_in1%get_state_matrix_ptr ()
state_in2 => int_in2%get_state_matrix_ptr ()
call find_connections (int_in1, int_in2, n_conn, connection_index)
if (n_conn == 0) then
call msg_message ("First interaction:")
call int_in1%basic_write (col_verbose=.true.)
call msg_message ("Second interaction:")
call int_in2%basic_write (col_verbose=.true.)
call msg_fatal ("Evaluator product: no connections found between factors")
end if
call compute_index_bounds_and_mappings &
(int_in1, int_in2, n_conn, &
n_in, n_vir, n_out, n_tot, &
n_rest, prt_map_in, prt_map_conn)
call prt_mask_init (prt_is_connected(1), int_in1%get_n_tot ())
call prt_mask_init (prt_is_connected(2), int_in2%get_n_tot ())
do i = 1, 2
prt_is_connected(i)%entry = .true.
prt_is_connected(i)%entry(connection_index(:,i)) = .false.
end do
allocate (qn_mask_conn_initial (n_conn), &
int_in1_mask (n_conn), int_in2_mask (n_conn))
int_in1_mask = int_in1%get_mask (connection_index(:,1))
int_in2_mask = int_in2%get_mask (connection_index(:,2))
do i = 1, n_conn
qn_mask_conn_initial(i) = int_in1_mask(i) .or. int_in2_mask(i)
end do
allocate (qn_mask_in(1)%mask (int_in1%get_n_tot ()))
allocate (qn_mask_in(2)%mask (int_in2%get_n_tot ()))
qn_mask_in(1)%mask = int_in1%get_mask ()
qn_mask_in(2)%mask = int_in2%get_mask ()
call connection_table_init (connection_table, &
state_in1, state_in2, &
qn_mask_conn_initial, &
n_conn, connection_index, n_rest, &
qn_filter_conn, ignore_sub_for_qn)
call connection_table_fill (connection_table, &
state_in1, state_in2, &
connection_index, prt_is_connected)
call make_product_interaction (eval%interaction_t, &
n_in, n_vir, n_out, &
connection_table, &
prt_map_in, prt_is_connected, &
qn_mask_in, qn_mask_conn_initial, &
qn_mask_conn, qn_filter_conn, qn_mask_rest)
call make_pairing_array (eval%pairing_array, &
eval%get_n_matrix_elements (), &
connection_table)
call record_links (eval%interaction_t, &
int_in1, int_in2, connection_index, prt_map_in, prt_map_conn, &
prt_is_connected, connections_are_resonant)
call connection_table_final (connection_table)
if (eval%get_n_matrix_elements () == 0) then
print *, "Evaluator product"
print *, "First interaction"
call int_in1%basic_write (col_verbose=.true.)
print *
print *, "Second interaction"
call int_in2%basic_write (col_verbose=.true.)
print *
call msg_fatal ("Product of density matrices is empty", &
[var_str (" --------------------------------------------"), &
var_str ("This happens when two density matrices are convoluted "), &
var_str ("but the processes they belong to (e.g., production "), &
var_str ("and decay) do not match. This could happen if the "), &
var_str ("beam specification does not match the hard "), &
var_str ("process. Or it may indicate a WHIZARD bug.")])
end if
contains
subroutine compute_index_bounds_and_mappings &
(int1, int2, n_conn, &
n_in, n_vir, n_out, n_tot, &
n_rest, prt_map_in, prt_map_conn)
class(interaction_t), intent(in) :: int1, int2
integer, intent(in) :: n_conn
integer, intent(out) :: n_in, n_vir, n_out, n_tot
integer, dimension(2), intent(out) :: n_rest
type(index_map_t), dimension(2), intent(out) :: prt_map_in
type(index_map_t), intent(out) :: prt_map_conn
integer, dimension(:), allocatable :: index
integer :: n_in1, n_vir1, n_out1
integer :: n_in2, n_vir2, n_out2
integer :: k
n_in1 = int1%get_n_in ()
n_vir1 = int1%get_n_vir ()
n_out1 = int1%get_n_out () - n_conn
n_rest(1) = n_in1 + n_vir1 + n_out1
n_in2 = int2%get_n_in () - n_conn
n_vir2 = int2%get_n_vir ()
n_out2 = int2%get_n_out ()
n_rest(2) = n_in2 + n_vir2 + n_out2
n_in = n_in1 + n_in2
n_vir = n_vir1 + n_vir2 + n_conn
n_out = n_out1 + n_out2
n_tot = n_in + n_vir + n_out
call index_map_init (prt_map_in, n_rest)
call index_map_init (prt_map_conn, n_conn)
allocate (index (n_tot))
index = [ (i, i = 1, n_tot) ]
prt_map_in(1)%entry(1 : n_in1) = index( 1 : n_in1)
k = n_in1
prt_map_in(2)%entry(1 : n_in2) = index(k + 1 : k + n_in2)
k = k + n_in2
prt_map_in(1)%entry(n_in1 + 1 : n_in1 + n_vir1) = index(k + 1 : k + n_vir1)
k = k + n_vir1
prt_map_in(2)%entry(n_in2 + 1 : n_in2 + n_vir2) = index(k + 1 : k + n_vir2)
k = k + n_vir2
prt_map_conn%entry = index(k + 1 : k + n_conn)
k = k + n_conn
prt_map_in(1)%entry(n_in1 + n_vir1 + 1 : n_rest(1)) = index(k + 1 : k + n_out1)
k = k + n_out1
prt_map_in(2)%entry(n_in2 + n_vir2 + 1 : n_rest(2)) = index(k + 1 : k + n_out2)
end subroutine compute_index_bounds_and_mappings
subroutine connection_table_init &
(connection_table, state_in1, state_in2, qn_mask_conn, &
n_conn, connection_index, n_rest, &
qn_filter_conn, ignore_sub_for_qn_in)
type(connection_table_t), intent(out) :: connection_table
type(state_matrix_t), intent(in), target :: state_in1, state_in2
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_conn
integer, intent(in) :: n_conn
integer, dimension(:,:), intent(in) :: connection_index
integer, dimension(2), intent(in) :: n_rest
type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
logical, intent(in), optional :: ignore_sub_for_qn_in
integer, dimension(2) :: n_me_in
type(state_iterator_t) :: it
type(quantum_numbers_t), dimension(n_conn) :: qn
integer :: i, me_index_in, me_index_conn, n_me_conn
integer, dimension(2) :: me_count
logical :: ignore_sub_for_qn, has_sub_qn
integer :: i_beam_sub
connection_table%n_conn = n_conn
connection_table%n_rest = n_rest
n_me_in(1) = state_in1%get_n_matrix_elements ()
n_me_in(2) = state_in2%get_n_matrix_elements ()
allocate (connection_table%index_conn (2))
call index_map_init (connection_table%index_conn, n_me_in)
call connection_table%state%init (n_counters = 2)
do i = 1, 2
select case (i)
case (1); call it%init (state_in1)
case (2); call it%init (state_in2)
end select
do while (it%is_valid ())
qn = it%get_quantum_numbers (connection_index(:,i))
call qn%undefine (qn_mask_conn)
if (present (qn_filter_conn)) then
if (.not. all (qn .match. qn_filter_conn)) then
call it%advance (); cycle
end if
end if
call quantum_numbers_canonicalize_color (qn)
me_index_in = it%get_me_index ()
ignore_sub_for_qn = .false.; if (present (ignore_sub_for_qn_in)) ignore_sub_for_qn = ignore_sub_for_qn_in
has_sub_qn = .false.
do i_beam_sub = 1, n_beams_rescaled
has_sub_qn = has_sub_qn .or. any (qn%get_sub () == i_beam_sub)
end do
call connection_table%state%add_state (qn, &
counter_index = i, &
ignore_sub_for_qn = .not. (ignore_sub_for_qn .and. has_sub_qn), &
me_index = me_index_conn)
call index_map_set_entry (connection_table%index_conn(i), &
me_index_in, me_index_conn)
call it%advance ()
end do
end do
n_me_conn = connection_table%state%get_n_matrix_elements ()
connection_table%n_me_conn = n_me_conn
allocate (connection_table%entry (n_me_conn))
call it%init (connection_table%state)
do while (it%is_valid ())
i = it%get_me_index ()
me_count = it%get_me_count ()
call connection_entry_init (connection_table%entry(i), 2, 2, &
it%get_quantum_numbers (), me_count, n_rest)
call it%advance ()
end do
end subroutine connection_table_init
subroutine connection_table_final (connection_table)
type(connection_table_t), intent(inout) :: connection_table
call connection_table%state%final ()
end subroutine connection_table_final
subroutine connection_table_write (connection_table, unit)
type(connection_table_t), intent(in) :: connection_table
integer, intent(in), optional :: unit
integer :: i, j
integer :: u
u = given_output_unit (unit)
write (u, *) "Connection table:"
call connection_table%state%write (unit)
if (allocated (connection_table%index_conn)) then
write (u, *) " Index mapping input => connection table:"
do i = 1, size (connection_table%index_conn)
write (u, *) " Input state", i
do j = 1, size (connection_table%index_conn(i))
write (u, *) j, &
index_map_get_entry (connection_table%index_conn(i), j)
end do
end do
end if
if (allocated (connection_table%entry)) then
write (u, *) " Connection table contents:"
do i = 1, size (connection_table%entry)
call connection_entry_write (connection_table%entry(i), unit)
end do
end if
if (index_map_exists (connection_table%index_result)) then
write (u, *) " Index mapping connection table => output:"
do i = 1, size (connection_table%index_result)
write (u, *) i, &
index_map_get_entry (connection_table%index_result, i)
end do
end if
end subroutine connection_table_write
subroutine connection_table_fill &
(connection_table, state_in1, state_in2, &
connection_index, prt_is_connected)
type(connection_table_t), intent(inout) :: connection_table
type(state_matrix_t), intent(in), target :: state_in1, state_in2
integer, dimension(:,:), intent(in) :: connection_index
type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected
type(state_iterator_t) :: it
integer :: index_in, index_conn
integer :: color_offset
integer :: n_result_entries
integer :: i, k
color_offset = connection_table%state%get_max_color_value ()
do i = 1, 2
select case (i)
case (1); call it%init (state_in1)
case (2); call it%init (state_in2)
end select
do while (it%is_valid ())
index_in = it%get_me_index ()
index_conn = index_map_get_entry &
(connection_table%index_conn(i), index_in)
if (index_conn /= 0) then
call connection_entry_add_state &
(connection_table%entry(index_conn), i, &
index_in, it%get_quantum_numbers (), &
connection_index(:,i), prt_is_connected(i), &
color_offset)
end if
call it%advance ()
end do
color_offset = color_offset + state_in1%get_max_color_value ()
end do
n_result_entries = 0
do k = 1, size (connection_table%entry)
n_result_entries = &
n_result_entries + product (connection_table%entry(k)%n_index)
end do
call index_map_init (connection_table%index_result, n_result_entries)
end subroutine connection_table_fill
subroutine connection_entry_add_state &
(entry, i, index_in, qn_in, connection_index, prt_is_connected, &
color_offset)
type(connection_entry_t), intent(inout) :: entry
integer, intent(in) :: i
integer, intent(in) :: index_in
type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
integer, dimension(:), intent(in) :: connection_index
type(prt_mask_t), intent(in) :: prt_is_connected
integer, intent(in) :: color_offset
integer :: c
integer, dimension(:,:), allocatable :: color_map
entry%count(i) = entry%count(i) + 1
c = entry%count(i)
call make_color_map (color_map, &
qn_in(connection_index), entry%qn_conn)
call index_map_set_entry (entry%index_in(i), c, index_in)
entry%qn_in_list(i)%qn(:,c) = pack (qn_in, prt_is_connected%entry)
call quantum_numbers_translate_color &
(entry%qn_in_list(i)%qn(:,c), color_map, color_offset)
end subroutine connection_entry_add_state
subroutine make_product_interaction (int, &
n_in, n_vir, n_out, &
connection_table, &
prt_map_in, prt_is_connected, &
qn_mask_in, qn_mask_conn_initial, &
qn_mask_conn, qn_filter_conn, qn_mask_rest)
type(interaction_t), intent(out), target :: int
integer, intent(in) :: n_in, n_vir, n_out
type(connection_table_t), intent(inout), target :: connection_table
type(index_map_t), dimension(2), intent(in) :: prt_map_in
type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected
type(qn_mask_array_t), dimension(2), intent(in) :: qn_mask_in
type(quantum_numbers_mask_t), dimension(:), intent(in) :: &
qn_mask_conn_initial
type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn
type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest
type(index_map_t), dimension(2) :: prt_index_in
type(index_map_t) :: prt_index_conn
integer :: n_tot, n_conn
integer, dimension(2) :: n_rest
integer :: i, j, k, m
type(quantum_numbers_t), dimension(:), allocatable :: qn
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
type(connection_entry_t), pointer :: entry
integer :: result_index
n_conn = connection_table%n_conn
n_rest = connection_table%n_rest
n_tot = sum (n_rest) + n_conn
allocate (qn (n_tot), qn_mask (n_tot))
do i = 1, 2
call index_map_init (prt_index_in(i), n_rest(i))
prt_index_in(i)%entry = &
prt_map_in(i)%entry ([ (j, j = 1, n_rest(i)) ])
end do
call index_map_init (prt_index_conn, n_conn)
prt_index_conn%entry = prt_map_conn%entry ([ (j, j = 1, n_conn) ])
do i = 1, 2
if (present (qn_mask_rest)) then
qn_mask(prt_index_in(i)%entry) = &
pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) &
.or. qn_mask_rest
else
qn_mask(prt_index_in(i)%entry) = &
pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry)
end if
end do
qn_mask(prt_index_conn%entry) = qn_mask_conn_initial .or. qn_mask_conn
call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask = qn_mask)
m = 1
do i = 1, connection_table%n_me_conn
entry => connection_table%entry(i)
qn(prt_index_conn%entry) = &
quantum_numbers_undefined (entry%qn_conn, qn_mask_conn)
if (present (qn_filter_conn)) then
if (.not. all (qn(prt_index_conn%entry) .match. qn_filter_conn)) &
cycle
end if
do j = 1, entry%n_index(1)
qn(prt_index_in(1)%entry) = entry%qn_in_list(1)%qn(:,j)
do k = 1, entry%n_index(2)
qn(prt_index_in(2)%entry) = entry%qn_in_list(2)%qn(:,k)
call int%add_state (qn, me_index = result_index)
call index_map_set_entry &
(connection_table%index_result, m, result_index)
m = m + 1
end do
end do
end do
call int%freeze ()
end subroutine make_product_interaction
subroutine make_pairing_array (pa, n_matrix_elements, connection_table)
type(pairing_array_t), dimension(:), intent(out), allocatable :: pa
integer, intent(in) :: n_matrix_elements
type(connection_table_t), intent(in), target :: connection_table
type(connection_entry_t), pointer :: entry
integer, dimension(:), allocatable :: n_entries
integer :: i, j, k, m, r
allocate (pa (n_matrix_elements))
allocate (n_entries (n_matrix_elements))
n_entries = 0
do m = 1, size (connection_table%index_result)
r = index_map_get_entry (connection_table%index_result, m)
n_entries(r) = n_entries(r) + 1
end do
call pairing_array_init &
(pa, n_entries, has_i2=.true., has_factor=.false.)
m = 1
n_entries = 0
do i = 1, connection_table%n_me_conn
entry => connection_table%entry(i)
do j = 1, entry%n_index(1)
do k = 1, entry%n_index(2)
r = index_map_get_entry (connection_table%index_result, m)
n_entries(r) = n_entries(r) + 1
pa(r)%i1(n_entries(r)) = &
index_map_get_entry (entry%index_in(1), j)
pa(r)%i2(n_entries(r)) = &
index_map_get_entry (entry%index_in(2), k)
m = m + 1
end do
end do
end do
end subroutine make_pairing_array
subroutine record_links (int, &
int_in1, int_in2, connection_index, prt_map_in, prt_map_conn, &
prt_is_connected, connections_are_resonant)
class(interaction_t), intent(inout) :: int
class(interaction_t), intent(in), target :: int_in1, int_in2
integer, dimension(:,:), intent(in) :: connection_index
type(index_map_t), dimension(2), intent(in) :: prt_map_in
type(index_map_t), intent(in) :: prt_map_conn
type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected
logical, intent(in), optional :: connections_are_resonant
type(index_map_t), dimension(2) :: prt_map_all
integer :: i, j, k, ival
call index_map_init (prt_map_all(1), size (prt_is_connected(1)))
k = 0
j = 0
do i = 1, size (prt_is_connected(1))
if (prt_is_connected(1)%entry(i)) then
j = j + 1
ival = index_map_get_entry (prt_map_in(1), j)
call index_map_set_entry (prt_map_all(1), i, ival)
else
k = k + 1
ival = index_map_get_entry (prt_map_conn, k)
call index_map_set_entry (prt_map_all(1), i, ival)
end if
call int%set_source_link (ival, int_in1, i)
end do
call int_in1%transfer_relations (int, prt_map_all(1)%entry)
call index_map_init (prt_map_all(2), size (prt_is_connected(2)))
j = 0
do i = 1, size (prt_is_connected(2))
if (prt_is_connected(2)%entry(i)) then
j = j + 1
ival = index_map_get_entry (prt_map_in(2), j)
call index_map_set_entry (prt_map_all(2), i, ival)
call int%set_source_link (ival, int_in2, i)
else
call index_map_set_entry (prt_map_all(2), i, 0)
end if
end do
call int_in2%transfer_relations (int, prt_map_all(2)%entry)
call int%relate_connections &
(int_in2, connection_index(:,2), prt_map_all(2)%entry, &
prt_map_conn%entry, connections_are_resonant)
end subroutine record_links
end subroutine evaluator_init_product
@ %def evaluator_init_product
@
\subsection{Creating an evaluator: square}
The generic initializer for an evaluator that squares a matrix element.
Depending on the provided mask, we select the appropriate specific initializer
for either diagonal or non-diagonal helicity density matrices.
<<Evaluators: evaluator: TBP>>=
procedure :: init_square => evaluator_init_square
<<Evaluators: sub interfaces>>=
module subroutine evaluator_init_square (eval, int_in, qn_mask, &
col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
class(evaluator_t), intent(out), target :: eval
class(interaction_t), intent(in), target :: int_in
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
integer, dimension(:,:), intent(in), optional :: col_flow_index
complex(default), dimension(:), intent(in), optional :: col_factor
integer, dimension(:), intent(in), optional :: col_index_hi
logical, intent(in), optional :: expand_color_flows
integer, intent(in), optional :: nc
end subroutine evaluator_init_square
<<Evaluators: procedures>>=
module subroutine evaluator_init_square (eval, int_in, qn_mask, &
col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
class(evaluator_t), intent(out), target :: eval
class(interaction_t), intent(in), target :: int_in
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
integer, dimension(:,:), intent(in), optional :: col_flow_index
complex(default), dimension(:), intent(in), optional :: col_factor
integer, dimension(:), intent(in), optional :: col_index_hi
logical, intent(in), optional :: expand_color_flows
integer, intent(in), optional :: nc
if (all (qn_mask%diagonal_helicity ())) then
call eval%init_square_diag (int_in, qn_mask, &
col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
else
call eval%init_square_nondiag (int_in, qn_mask, &
col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
end if
end subroutine evaluator_init_square
@ %def evaluator_init_square
@
\subsubsection{Color-summed squared matrix (diagonal helicities)}
The initializer for an evaluator that squares a matrix element,
including color factors. The mask must be such that off-diagonal matrix
elements are excluded.
If [[color_flows]] is set, the evaluator keeps color-flow entries
separate and drops all interfering color structures. The color factors are
set to unity in this case.
There is only one input interaction. The quantum-number mask is an
array, one entry for each particle, so they can be treated
individually. For academic purposes, we allow for the number of
colors being different from three (but 3 is the default).
The algorithm is analogous to multiplication, with a few notable
differences:
\begin{enumerate}
\item
The connected particles are known, the correspondence is
one-to-one. All particles are connected, and the mapping of indices
is trivial, which simplifies the following steps.
\item
[[accumulate_connected_states]]: The matrix of connected states
encompasses all particles, but color indices are removed. However,
ghost states are still kept separate from physical color states. No
color-index reassignment is necessary.
\item
The table of connections contains single index and quantum-number
arrays instead of pairs of them. They are paired with themselves
in all possible ways.
\item
[[make_squared_interaction]]: Now apply the predefined
quantum-numbers mask, which usually collects all color states
(physical and ghosts), and possibly a helicity sum.
\item
[[make_pairing_array]]: For each pair of input states, compute the
color factor (including a potential ghost-parity sign) and store
this in the pairing array together with the matrix-element indices
for multiplication.
\item
[[record_links]]: This is again trivial due to the one-to-one
correspondence.
\end{enumerate}
<<Evaluators: evaluator: TBP>>=
procedure :: init_square_diag => evaluator_init_square_diag
<<Evaluators: sub interfaces>>=
module subroutine evaluator_init_square_diag (eval, int_in, qn_mask, &
col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
class(evaluator_t), intent(out), target :: eval
class(interaction_t), intent(in), target :: int_in
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
integer, dimension(:,:), intent(in), optional :: col_flow_index
complex(default), dimension(:), intent(in), optional :: col_factor
integer, dimension(:), intent(in), optional :: col_index_hi
logical, intent(in), optional :: expand_color_flows
integer, intent(in), optional :: nc
end subroutine evaluator_init_square_diag
<<Evaluators: procedures>>=
module subroutine evaluator_init_square_diag (eval, int_in, qn_mask, &
col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
class(evaluator_t), intent(out), target :: eval
class(interaction_t), intent(in), target :: int_in
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
integer, dimension(:,:), intent(in), optional :: col_flow_index
complex(default), dimension(:), intent(in), optional :: col_factor
integer, dimension(:), intent(in), optional :: col_index_hi
logical, intent(in), optional :: expand_color_flows
integer, intent(in), optional :: nc
integer :: n_in, n_vir, n_out, n_tot
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_initial
type(state_matrix_t), pointer :: state_in
type(connection_table_diag_t) :: connection_table
logical :: sum_colors
type(color_table_t) :: color_table
if (present (expand_color_flows)) then
sum_colors = .not. expand_color_flows
else
sum_colors = .true.
end if
if (sum_colors) then
eval%type = EVAL_SQUARE_WITH_COLOR_FACTORS
else
eval%type = EVAL_SQUARED_FLOWS
end if
eval%int_in1 => int_in
n_in = int_in%get_n_in ()
n_vir = int_in%get_n_vir ()
n_out = int_in%get_n_out ()
n_tot = int_in%get_n_tot ()
state_in => int_in%get_state_matrix_ptr ()
allocate (qn_mask_initial (n_tot))
qn_mask_initial = int_in%get_mask ()
call qn_mask_initial%set_color (sum_colors, mask_cg=.false.)
if (sum_colors) then
call color_table_init (color_table, state_in, n_tot)
if (present (col_flow_index) .and. present (col_factor) &
.and. present (col_index_hi)) then
call color_table_set_color_factors &
(color_table, col_flow_index, col_factor, col_index_hi)
end if
end if
call connection_table_init (connection_table, state_in, &
qn_mask_initial, qn_mask, n_tot)
call connection_table_fill (connection_table, state_in)
call make_squared_interaction (eval%interaction_t, &
n_in, n_vir, n_out, n_tot, &
connection_table, sum_colors, qn_mask_initial .or. qn_mask)
call make_pairing_array (eval%pairing_array, &
eval%get_n_matrix_elements (), &
connection_table, sum_colors, color_table, n_in, n_tot, nc)
call record_links (eval, int_in, n_tot)
call connection_table_final (connection_table)
contains
subroutine connection_table_init &
(connection_table, state_in, qn_mask_in, qn_mask, n_tot)
type(connection_table_diag_t), intent(out) :: connection_table
type(state_matrix_t), intent(in), target :: state_in
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
integer, intent(in) :: n_tot
type(quantum_numbers_t), dimension(n_tot) :: qn
type(state_iterator_t) :: it
integer :: i, n_me_in, me_index_in
integer :: me_index_conn, n_me_conn
integer, dimension(1) :: me_count
logical :: qn_passed
connection_table%n_tot = n_tot
n_me_in = state_in%get_n_matrix_elements ()
call index_map_init (connection_table%index_conn, n_me_in)
call connection_table%state%init (n_counters=1)
call it%init (state_in)
do while (it%is_valid ())
qn = it%get_quantum_numbers ()
if (all (quantum_numbers_are_physical (qn, qn_mask))) then
call qn%undefine (qn_mask_in)
qn_passed = .true.
if (qn_passed) then
me_index_in = it%get_me_index ()
call connection_table%state%add_state (qn, &
counter_index = 1, me_index = me_index_conn)
call index_map_set_entry (connection_table%index_conn, &
me_index_in, me_index_conn)
end if
end if
call it%advance ()
end do
n_me_conn = connection_table%state%get_n_matrix_elements ()
connection_table%n_me_conn = n_me_conn
allocate (connection_table%entry (n_me_conn))
call it%init (connection_table%state)
do while (it%is_valid ())
i = it%get_me_index ()
me_count = it%get_me_count ()
call connection_entry_init (connection_table%entry(i), 1, 2, &
it%get_quantum_numbers (), me_count, [n_tot])
call it%advance ()
end do
end subroutine connection_table_init
subroutine connection_table_final (connection_table)
type(connection_table_diag_t), intent(inout) :: connection_table
call connection_table%state%final ()
end subroutine connection_table_final
subroutine connection_table_write (connection_table, unit)
type(connection_table_diag_t), intent(in) :: connection_table
integer, intent(in), optional :: unit
integer :: i
integer :: u
u = given_output_unit (unit)
write (u, *) "Connection table:"
call connection_table%state%write (unit)
if (index_map_exists (connection_table%index_conn)) then
write (u, *) " Index mapping input => connection table:"
do i = 1, size (connection_table%index_conn)
write (u, *) i, &
index_map_get_entry (connection_table%index_conn, i)
end do
end if
if (allocated (connection_table%entry)) then
write (u, *) " Connection table contents"
do i = 1, size (connection_table%entry)
call connection_entry_write (connection_table%entry(i), unit)
end do
end if
if (index_map_exists (connection_table%index_result)) then
write (u, *) " Index mapping connection table => output"
do i = 1, size (connection_table%index_result)
write (u, *) i, &
index_map_get_entry (connection_table%index_result, i)
end do
end if
end subroutine connection_table_write
subroutine connection_table_fill (connection_table, state)
type(connection_table_diag_t), intent(inout) :: connection_table
type(state_matrix_t), intent(in), target :: state
integer :: index_in, index_conn, n_result_entries
type(state_iterator_t) :: it
integer :: k
call it%init (state)
do while (it%is_valid ())
index_in = it%get_me_index ()
index_conn = &
index_map_get_entry (connection_table%index_conn, index_in)
if (index_conn /= 0) then
call connection_entry_add_state &
(connection_table%entry(index_conn), &
index_in, it%get_quantum_numbers ())
end if
call it%advance ()
end do
n_result_entries = 0
do k = 1, size (connection_table%entry)
n_result_entries = &
n_result_entries + connection_table%entry(k)%n_index(1) ** 2
end do
call index_map_init (connection_table%index_result, n_result_entries)
end subroutine connection_table_fill
subroutine connection_entry_add_state (entry, index_in, qn_in)
type(connection_entry_t), intent(inout) :: entry
integer, intent(in) :: index_in
type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
integer :: c
entry%count = entry%count + 1
c = entry%count(1)
call index_map_set_entry (entry%index_in(1), c, index_in)
entry%qn_in_list(1)%qn(:,c) = qn_in
end subroutine connection_entry_add_state
subroutine make_squared_interaction (int, &
n_in, n_vir, n_out, n_tot, &
connection_table, sum_colors, qn_mask)
type(interaction_t), intent(out), target :: int
integer, intent(in) :: n_in, n_vir, n_out, n_tot
type(connection_table_diag_t), intent(inout), target :: connection_table
logical, intent(in) :: sum_colors
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
type(connection_entry_t), pointer :: entry
integer :: result_index, n_contrib
integer :: i, m
type(quantum_numbers_t), dimension(n_tot) :: qn
call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask=qn_mask)
m = 0
do i = 1, connection_table%n_me_conn
entry => connection_table%entry(i)
qn = quantum_numbers_undefined (entry%qn_conn, qn_mask)
if (.not. sum_colors) call qn(1:n_in)%invert_color ()
call int%add_state (qn, me_index = result_index)
n_contrib = entry%n_index(1) ** 2
connection_table%index_result%entry(m+1:m+n_contrib) = result_index
m = m + n_contrib
end do
call int%freeze ()
end subroutine make_squared_interaction
subroutine make_pairing_array (pa, &
n_matrix_elements, connection_table, sum_colors, color_table, &
n_in, n_tot, nc)
type(pairing_array_t), dimension(:), intent(out), allocatable :: pa
integer, intent(in) :: n_matrix_elements
type(connection_table_diag_t), intent(in), target :: connection_table
logical, intent(in) :: sum_colors
type(color_table_t), intent(inout) :: color_table
type(connection_entry_t), pointer :: entry
integer, intent(in) :: n_in, n_tot
integer, intent(in), optional :: nc
integer, dimension(:), allocatable :: n_entries
integer :: i, k, l, ks, ls, m, r
integer :: color_multiplicity_in
allocate (pa (n_matrix_elements))
allocate (n_entries (n_matrix_elements))
n_entries = 0
do m = 1, size (connection_table%index_result)
r = index_map_get_entry (connection_table%index_result, m)
n_entries(r) = n_entries(r) + 1
end do
call pairing_array_init &
(pa, n_entries, has_i2 = sum_colors, has_factor = sum_colors)
m = 1
n_entries = 0
do i = 1, connection_table%n_me_conn
entry => connection_table%entry(i)
do k = 1, entry%n_index(1)
if (sum_colors) then
color_multiplicity_in = product (abs &
(entry%qn_in_list(1)%qn(:n_in, k)%get_color_type ()))
do l = 1, entry%n_index(1)
r = index_map_get_entry (connection_table%index_result, m)
n_entries(r) = n_entries(r) + 1
ks = index_map_get_entry (entry%index_in(1), k)
ls = index_map_get_entry (entry%index_in(1), l)
pa(r)%i1(n_entries(r)) = ks
pa(r)%i2(n_entries(r)) = ls
pa(r)%factor(n_entries(r)) = &
color_table_get_color_factor (color_table, ks, ls, nc) &
/ color_multiplicity_in
m = m + 1
end do
else
r = index_map_get_entry (connection_table%index_result, m)
n_entries(r) = n_entries(r) + 1
ks = index_map_get_entry (entry%index_in(1), k)
pa(r)%i1(n_entries(r)) = ks
m = m + 1
end if
end do
end do
end subroutine make_pairing_array
subroutine record_links (int, int_in, n_tot)
class(interaction_t), intent(inout) :: int
class(interaction_t), intent(in), target :: int_in
integer, intent(in) :: n_tot
integer, dimension(n_tot) :: map
integer :: i
do i = 1, n_tot
call int%set_source_link (i, int_in, i)
end do
map = [ (i, i = 1, n_tot) ]
call int_in%transfer_relations (int, map)
end subroutine record_links
end subroutine evaluator_init_square_diag
@ %def evaluator_init_square_diag
@
\subsubsection{Color-summed squared matrix (support nodiagonal helicities)}
The initializer for an evaluator that squares a matrix element,
including color factors. Unless requested otherwise by the
quantum-number mask, the result contains off-diagonal matrix elements.
(The input interaction must be diagonal since it represents an
amplitude, not a density matrix.)
There is only one input interaction. The quantum-number mask is an
array, one entry for each particle, so they can be treated
individually. For academic purposes, we allow for the number of
colors being different from three (but 3 is the default).
The algorithm is analogous to the previous one, with some additional
complications due to the necessity to loop over two helicity indices.
<<Evaluators: evaluator: TBP>>=
procedure :: init_square_nondiag => evaluator_init_square_nondiag
<<Evaluators: sub interfaces>>=
module subroutine evaluator_init_square_nondiag (eval, int_in, qn_mask, &
col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
class(evaluator_t), intent(out), target :: eval
class(interaction_t), intent(in), target :: int_in
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
integer, dimension(:,:), intent(in), optional :: col_flow_index
complex(default), dimension(:), intent(in), optional :: col_factor
integer, dimension(:), intent(in), optional :: col_index_hi
logical, intent(in), optional :: expand_color_flows
integer, intent(in), optional :: nc
end subroutine evaluator_init_square_nondiag
<<Evaluators: procedures>>=
module subroutine evaluator_init_square_nondiag (eval, int_in, qn_mask, &
col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
class(evaluator_t), intent(out), target :: eval
class(interaction_t), intent(in), target :: int_in
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
integer, dimension(:,:), intent(in), optional :: col_flow_index
complex(default), dimension(:), intent(in), optional :: col_factor
integer, dimension(:), intent(in), optional :: col_index_hi
logical, intent(in), optional :: expand_color_flows
integer, intent(in), optional :: nc
integer :: n_in, n_vir, n_out, n_tot
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_initial
type(state_matrix_t), pointer :: state_in
type(connection_table_nondiag_t) :: connection_table
logical :: sum_colors
type(color_table_t) :: color_table
if (present (expand_color_flows)) then
sum_colors = .not. expand_color_flows
else
sum_colors = .true.
end if
if (sum_colors) then
eval%type = EVAL_SQUARE_WITH_COLOR_FACTORS
else
eval%type = EVAL_SQUARED_FLOWS
end if
eval%int_in1 => int_in
n_in = int_in%get_n_in ()
n_vir = int_in%get_n_vir ()
n_out = int_in%get_n_out ()
n_tot = int_in%get_n_tot ()
state_in => int_in%get_state_matrix_ptr ()
allocate (qn_mask_initial (n_tot))
qn_mask_initial = int_in%get_mask ()
call qn_mask_initial%set_color (sum_colors, mask_cg=.false.)
if (sum_colors) then
call color_table_init (color_table, state_in, n_tot)
if (present (col_flow_index) .and. present (col_factor) &
.and. present (col_index_hi)) then
call color_table_set_color_factors &
(color_table, col_flow_index, col_factor, col_index_hi)
end if
end if
call connection_table_init (connection_table, state_in, &
qn_mask_initial, qn_mask, n_tot)
call connection_table_fill (connection_table, state_in)
call make_squared_interaction (eval%interaction_t, &
n_in, n_vir, n_out, n_tot, &
connection_table, sum_colors, qn_mask_initial .or. qn_mask)
call make_pairing_array (eval%pairing_array, &
eval%get_n_matrix_elements (), &
connection_table, sum_colors, color_table, n_in, n_tot, nc)
call record_links (eval, int_in, n_tot)
call connection_table_final (connection_table)
contains
subroutine connection_table_init &
(connection_table, state_in, qn_mask_in, qn_mask, n_tot)
type(connection_table_nondiag_t), intent(out) :: connection_table
type(state_matrix_t), intent(in), target :: state_in
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
integer, intent(in) :: n_tot
type(quantum_numbers_t), dimension(n_tot) :: qn1, qn2, qn
type(state_iterator_t) :: it1, it2, it
integer :: i, n_me_in, me_index_in1, me_index_in2
integer :: me_index_conn, n_me_conn
integer, dimension(1) :: me_count
logical :: qn_passed
connection_table%n_tot = n_tot
n_me_in = state_in%get_n_matrix_elements ()
call index_map2_init (connection_table%index_conn, n_me_in)
connection_table%index_conn = 0
call connection_table%state%init (n_counters=1)
call it1%init (state_in)
do while (it1%is_valid ())
qn1 = it1%get_quantum_numbers ()
me_index_in1 = it1%get_me_index ()
call it2%init (state_in)
do while (it2%is_valid ())
qn2 = it2%get_quantum_numbers ()
if (all (quantum_numbers_are_compatible (qn1, qn2, qn_mask))) then
qn = qn1 .merge. qn2
call qn%undefine (qn_mask_in)
qn_passed = .true.
if (qn_passed) then
me_index_in2 = it2%get_me_index ()
call connection_table%state%add_state (qn, &
counter_index = 1, me_index = me_index_conn)
call index_map2_set_entry (connection_table%index_conn, &
me_index_in1, me_index_in2, me_index_conn)
end if
end if
call it2%advance ()
end do
call it1%advance ()
end do
n_me_conn = connection_table%state%get_n_matrix_elements ()
connection_table%n_me_conn = n_me_conn
allocate (connection_table%entry (n_me_conn))
call it%init (connection_table%state)
do while (it%is_valid ())
i = it%get_me_index ()
me_count = it%get_me_count ()
call connection_entry_init (connection_table%entry(i), 1, 2, &
it%get_quantum_numbers (), me_count, [n_tot])
call it%advance ()
end do
end subroutine connection_table_init
subroutine connection_table_final (connection_table)
type(connection_table_nondiag_t), intent(inout) :: connection_table
call connection_table%state%final ()
end subroutine connection_table_final
subroutine connection_table_write (connection_table, unit)
type(connection_table_nondiag_t), intent(in) :: connection_table
integer, intent(in), optional :: unit
integer :: i, j
integer :: u
u = given_output_unit (unit)
write (u, *) "Connection table:"
call connection_table%state%write (unit)
if (index_map2_exists (connection_table%index_conn)) then
write (u, *) " Index mapping input => connection table:"
do i = 1, size (connection_table%index_conn)
do j = 1, size (connection_table%index_conn)
write (u, *) i, j, &
index_map2_get_entry (connection_table%index_conn, i, j)
end do
end do
end if
if (allocated (connection_table%entry)) then
write (u, *) " Connection table contents"
do i = 1, size (connection_table%entry)
call connection_entry_write (connection_table%entry(i), unit)
end do
end if
if (index_map_exists (connection_table%index_result)) then
write (u, *) " Index mapping connection table => output"
do i = 1, size (connection_table%index_result)
write (u, *) i, &
index_map_get_entry (connection_table%index_result, i)
end do
end if
end subroutine connection_table_write
subroutine connection_table_fill (connection_table, state)
type(connection_table_nondiag_t), intent(inout), target :: connection_table
type(state_matrix_t), intent(in), target :: state
integer :: index1_in, index2_in, index_conn, n_result_entries
type(state_iterator_t) :: it1, it2
integer :: k
call it1%init (state)
do while (it1%is_valid ())
index1_in = it1%get_me_index ()
call it2%init (state)
do while (it2%is_valid ())
index2_in = it2%get_me_index ()
index_conn = index_map2_get_entry &
(connection_table%index_conn, index1_in, index2_in)
if (index_conn /= 0) then
call connection_entry_add_state &
(connection_table%entry(index_conn), &
index1_in, index2_in, &
it1%get_quantum_numbers () &
.merge. &
it2%get_quantum_numbers ())
end if
call it2%advance ()
end do
call it1%advance ()
end do
n_result_entries = 0
do k = 1, size (connection_table%entry)
n_result_entries = &
n_result_entries + connection_table%entry(k)%n_index(1)
end do
call index_map_init (connection_table%index_result, n_result_entries)
end subroutine connection_table_fill
subroutine connection_entry_add_state (entry, index1_in, index2_in, qn_in)
type(connection_entry_t), intent(inout) :: entry
integer, intent(in) :: index1_in, index2_in
type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
integer :: c
entry%count = entry%count + 1
c = entry%count(1)
call index_map_set_entry (entry%index_in(1), c, index1_in)
call index_map_set_entry (entry%index_in(2), c, index2_in)
entry%qn_in_list(1)%qn(:,c) = qn_in
end subroutine connection_entry_add_state
subroutine make_squared_interaction (int, &
n_in, n_vir, n_out, n_tot, &
connection_table, sum_colors, qn_mask)
type(interaction_t), intent(out), target :: int
integer, intent(in) :: n_in, n_vir, n_out, n_tot
type(connection_table_nondiag_t), intent(inout), target :: connection_table
logical, intent(in) :: sum_colors
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
type(connection_entry_t), pointer :: entry
integer :: result_index
integer :: i, k, m
type(quantum_numbers_t), dimension(n_tot) :: qn
call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask=qn_mask)
m = 0
do i = 1, connection_table%n_me_conn
entry => connection_table%entry(i)
do k = 1, size (entry%qn_in_list(1)%qn, 2)
qn = quantum_numbers_undefined &
(entry%qn_in_list(1)%qn(:,k), qn_mask)
if (.not. sum_colors) call qn(1:n_in)%invert_color ()
call int%add_state (qn, me_index = result_index)
call index_map_set_entry (connection_table%index_result, m + 1, &
result_index)
m = m + 1
end do
end do
call int%freeze ()
end subroutine make_squared_interaction
subroutine make_pairing_array (pa, &
n_matrix_elements, connection_table, sum_colors, color_table, &
n_in, n_tot, nc)
type(pairing_array_t), dimension(:), intent(out), allocatable :: pa
integer, intent(in) :: n_matrix_elements
type(connection_table_nondiag_t), intent(in), target :: connection_table
logical, intent(in) :: sum_colors
type(color_table_t), intent(inout) :: color_table
type(connection_entry_t), pointer :: entry
integer, intent(in) :: n_in, n_tot
integer, intent(in), optional :: nc
integer, dimension(:), allocatable :: n_entries
integer :: i, k, k1s, k2s, m, r
integer :: color_multiplicity_in
allocate (pa (n_matrix_elements))
allocate (n_entries (n_matrix_elements))
n_entries = 0
do m = 1, size (connection_table%index_result)
r = index_map_get_entry (connection_table%index_result, m)
n_entries(r) = n_entries(r) + 1
end do
call pairing_array_init &
(pa, n_entries, has_i2 = sum_colors, has_factor = sum_colors)
m = 1
n_entries = 0
do i = 1, connection_table%n_me_conn
entry => connection_table%entry(i)
do k = 1, entry%n_index(1)
r = index_map_get_entry (connection_table%index_result, m)
n_entries(r) = n_entries(r) + 1
if (sum_colors) then
k1s = index_map_get_entry (entry%index_in(1), k)
k2s = index_map_get_entry (entry%index_in(2), k)
pa(r)%i1(n_entries(r)) = k1s
pa(r)%i2(n_entries(r)) = k2s
color_multiplicity_in = product (abs &
(entry%qn_in_list(1)%qn(:n_in, k)%get_color_type ()))
pa(r)%factor(n_entries(r)) = &
color_table_get_color_factor (color_table, k1s, k2s, nc) &
/ color_multiplicity_in
else
k1s = index_map_get_entry (entry%index_in(1), k)
pa(r)%i1(n_entries(r)) = k1s
end if
m = m + 1
end do
end do
end subroutine make_pairing_array
subroutine record_links (int, int_in, n_tot)
class(interaction_t), intent(inout) :: int
class(interaction_t), intent(in), target :: int_in
integer, intent(in) :: n_tot
integer, dimension(n_tot) :: map
integer :: i
do i = 1, n_tot
call int%set_source_link (i, int_in, i)
end do
map = [ (i, i = 1, n_tot) ]
call int_in%transfer_relations (int, map)
end subroutine record_links
end subroutine evaluator_init_square_nondiag
@ %def evaluator_init_square_nondiag
@
\subsubsection{Copy with additional contracted color states}
This evaluator involves no square or multiplication, its matrix
elements are just copies of the (single) input interaction. However,
the state matrix of the interaction contains additional states that
have color indices contracted. This is used for copies of the beam or
structure-function interactions that need to match the hard
interaction also in the case where its color indices coincide.
<<Evaluators: evaluator: TBP>>=
procedure :: init_color_contractions => evaluator_init_color_contractions
<<Evaluators: sub interfaces>>=
module subroutine evaluator_init_color_contractions (eval, int_in)
class(evaluator_t), intent(out), target :: eval
type(interaction_t), intent(in), target :: int_in
end subroutine evaluator_init_color_contractions
<<Evaluators: procedures>>=
module subroutine evaluator_init_color_contractions (eval, int_in)
class(evaluator_t), intent(out), target :: eval
type(interaction_t), intent(in), target :: int_in
integer :: n_in, n_vir, n_out, n_tot
type(state_matrix_t) :: state_with_contractions
integer, dimension(:), allocatable :: me_index
integer, dimension(:), allocatable :: result_index
eval%type = EVAL_COLOR_CONTRACTION
eval%int_in1 => int_in
n_in = int_in%get_n_in ()
n_vir = int_in%get_n_vir ()
n_out = int_in%get_n_out ()
n_tot = int_in%get_n_tot ()
state_with_contractions = int_in%get_state_matrix_ptr ()
call state_with_contractions%add_color_contractions ()
call make_contracted_interaction (eval%interaction_t, &
me_index, result_index, &
n_in, n_vir, n_out, n_tot, &
state_with_contractions, int_in%get_mask ())
call make_pairing_array (eval%pairing_array, me_index, result_index)
call record_links (eval, int_in, n_tot)
call state_with_contractions%final ()
contains
subroutine make_contracted_interaction (int, &
me_index, result_index, &
n_in, n_vir, n_out, n_tot, state, qn_mask)
type(interaction_t), intent(out), target :: int
integer, dimension(:), intent(out), allocatable :: me_index
integer, dimension(:), intent(out), allocatable :: result_index
integer, intent(in) :: n_in, n_vir, n_out, n_tot
type(state_matrix_t), intent(in) :: state
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
type(state_iterator_t) :: it
integer :: n_me, i
type(quantum_numbers_t), dimension(n_tot) :: qn
call int%basic_init (n_in, n_vir, n_out, mask=qn_mask)
n_me = state%get_n_leaves ()
allocate (me_index (n_me))
allocate (result_index (n_me))
call it%init (state)
i = 0
do while (it%is_valid ())
i = i + 1
me_index(i) = it%get_me_index ()
qn = it%get_quantum_numbers ()
call int%add_state (qn, me_index = result_index(i))
call it%advance ()
end do
call int%freeze ()
end subroutine make_contracted_interaction
subroutine make_pairing_array (pa, me_index, result_index)
type(pairing_array_t), dimension(:), intent(out), allocatable :: pa
integer, dimension(:), intent(in) :: me_index, result_index
integer, dimension(:), allocatable :: n_entries
integer :: n_matrix_elements, r, i, k
!!! The result indices of the appended color contracted states
!!! start counting from 1 again. For the pairing array, we currently
!!! only take the first part of ascending indices into account
!!! excluding the color contracted states.
n_matrix_elements = size (me_index)
k = 0
do i = 1, n_matrix_elements
r = result_index(i)
if (r < i) exit
k = r
end do
allocate (pa (k))
allocate (n_entries (k))
n_entries = 1
call pairing_array_init &
(pa, n_entries, has_i2=.false., has_factor=.false.)
do i = 1, k
r = result_index(i)
pa(r)%i1(1) = me_index(i)
end do
end subroutine make_pairing_array
subroutine record_links (int, int_in, n_tot)
class(interaction_t), intent(inout) :: int
class(interaction_t), intent(in), target :: int_in
integer, intent(in) :: n_tot
integer, dimension(n_tot) :: map
integer :: i
do i = 1, n_tot
call int%set_source_link (i, int_in, i)
end do
map = [ (i, i = 1, n_tot) ]
call int_in%transfer_relations (int, map)
end subroutine record_links
end subroutine evaluator_init_color_contractions
@ %def evaluator_init_color_contractions
@
\subsubsection{Auxiliary procedure for initialization}
This will become a standard procedure in F2008. The result is true if
the number of true values in the mask is odd. We use the function for
determining the ghost parity of a quantum-number array.
[tho:] It's not used anymore and [[mod (count (mask), 2) == 1]] is
a cooler implementation anyway.
<<(UNUSED) Evaluators: procedures>>=
function parity (mask)
logical :: parity
logical, dimension(:) :: mask
integer :: i
parity = .false.
do i = 1, size (mask)
if (mask(i)) parity = .not. parity
end do
end function parity
@ %def parity
@ Reassign external source links from one to another.
<<Evaluators: public>>=
public :: evaluator_reassign_links
<<Evaluators: interfaces>>=
interface evaluator_reassign_links
module procedure evaluator_reassign_links_eval
module procedure evaluator_reassign_links_int
end interface
<<Evaluators: sub interfaces>>=
module subroutine evaluator_reassign_links_eval (eval, eval_src, eval_target)
type(evaluator_t), intent(inout) :: eval
type(evaluator_t), intent(in) :: eval_src
type(evaluator_t), intent(in), target :: eval_target
end subroutine evaluator_reassign_links_eval
module subroutine evaluator_reassign_links_int (eval, int_src, int_target)
type(evaluator_t), intent(inout) :: eval
type(interaction_t), intent(in) :: int_src
type(interaction_t), intent(in), target :: int_target
end subroutine evaluator_reassign_links_int
<<Evaluators: procedures>>=
module subroutine evaluator_reassign_links_eval (eval, eval_src, eval_target)
type(evaluator_t), intent(inout) :: eval
type(evaluator_t), intent(in) :: eval_src
type(evaluator_t), intent(in), target :: eval_target
if (associated (eval%int_in1)) then
if (eval%int_in1%get_tag () == eval_src%get_tag ()) then
eval%int_in1 => eval_target%interaction_t
end if
end if
if (associated (eval%int_in2)) then
if (eval%int_in2%get_tag () == eval_src%get_tag ()) then
eval%int_in2 => eval_target%interaction_t
end if
end if
call interaction_reassign_links &
(eval%interaction_t, eval_src%interaction_t, &
eval_target%interaction_t)
end subroutine evaluator_reassign_links_eval
module subroutine evaluator_reassign_links_int (eval, int_src, int_target)
type(evaluator_t), intent(inout) :: eval
type(interaction_t), intent(in) :: int_src
type(interaction_t), intent(in), target :: int_target
if (associated (eval%int_in1)) then
if (eval%int_in1%get_tag () == int_src%get_tag ()) then
eval%int_in1 => int_target
end if
end if
if (associated (eval%int_in2)) then
if (eval%int_in2%get_tag () == int_src%get_tag ()) then
eval%int_in2 => int_target
end if
end if
call interaction_reassign_links (eval%interaction_t, int_src, int_target)
end subroutine evaluator_reassign_links_int
@ %def evaluator_reassign_links
@
<<Evaluators: public>>=
public :: evaluator_get_int_in_ptr
<<Evaluators: sub interfaces>>=
module function evaluator_get_int_in_ptr (eval, i) result (int_in)
class(interaction_t), pointer :: int_in
type(evaluator_t), intent(in), target :: eval
integer, intent(in) :: i
end function evaluator_get_int_in_ptr
<<Evaluators: procedures>>=
module function evaluator_get_int_in_ptr (eval, i) result (int_in)
class(interaction_t), pointer :: int_in
type(evaluator_t), intent(in), target :: eval
integer, intent(in) :: i
if (i == 1) then
int_in => eval%int_in1
else if (i == 2) then
int_in => eval%int_in2
else
int_in => null ()
end if
end function evaluator_get_int_in_ptr
@ %def evaluator_get_int_in_ptr
@
\subsection{Creating an evaluator: identity}
The identity evaluator creates a copy of the first input evaluator; the second
input is not used.
All particles link back to the input evaluatorand the internal
relations are copied. As evaluation does take a shortcut by cloning the matrix
elements, the pairing array is not used and does not have to be set up.
<<Evaluators: evaluator: TBP>>=
procedure :: init_identity => evaluator_init_identity
<<Evaluators: sub interfaces>>=
module subroutine evaluator_init_identity (eval, int)
class(evaluator_t), intent(out), target :: eval
class(interaction_t), intent(in), target :: int
end subroutine evaluator_init_identity
<<Evaluators: procedures>>=
module subroutine evaluator_init_identity (eval, int)
class(evaluator_t), intent(out), target :: eval
class(interaction_t), intent(in), target :: int
integer :: n_in, n_out, n_vir, n_tot
integer :: i
integer, dimension(:), allocatable :: map
type(state_matrix_t), pointer :: state
type(state_iterator_t) :: it
eval%type = EVAL_IDENTITY
eval%int_in1 => int
nullify (eval%int_in2)
n_in = int%get_n_in ()
n_out = int%get_n_out ()
n_vir = int%get_n_vir ()
n_tot = int%get_n_tot ()
call eval%interaction_t%basic_init (n_in, n_vir, n_out, &
mask = int%get_mask (), &
resonant = int%get_resonance_flags ())
do i = 1, n_tot
call eval%set_source_link (i, int, i)
end do
allocate (map(n_tot))
map = [(i, i = 1, n_tot)]
call int%transfer_relations (eval, map)
state => int%get_state_matrix_ptr ()
call it%init (state)
do while (it%is_valid ())
call eval%add_state (it%get_quantum_numbers (), &
it%get_me_index ())
call it%advance ()
end do
call eval%freeze ()
end subroutine evaluator_init_identity
@ %def evaluator_init_identity
@
\subsection {Creating an evaluator: quantum number sum}
This evaluator operates on the diagonal of a density matrix and sums over the
quantum numbers specified by the mask. The optional argument [[drop]] allows to
drop a particle from the resulting density matrix. The handling of virtuals is
not completely sane, especially in connection with dropping particles.
When summing over matrix element entries, we keep the separation into
entries and normalization (in the corresponding evaluation routine below).
<<Evaluators: evaluator: TBP>>=
procedure :: init_qn_sum => evaluator_init_qn_sum
<<Evaluators: sub interfaces>>=
module subroutine evaluator_init_qn_sum (eval, int, qn_mask, drop)
class(evaluator_t), intent(out), target :: eval
class(interaction_t), target, intent(in) :: int
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
logical, intent(in), optional, dimension(:) :: drop
end subroutine evaluator_init_qn_sum
<<Evaluators: procedures>>=
module subroutine evaluator_init_qn_sum (eval, int, qn_mask, drop)
class(evaluator_t), intent(out), target :: eval
class(interaction_t), target, intent(in) :: int
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
logical, intent(in), optional, dimension(:) :: drop
type(state_iterator_t) :: it_old, it_new
integer, dimension(:), allocatable :: pairing_size, pairing_target, i_new
integer, dimension(:), allocatable :: map
integer :: n_in, n_out, n_vir, n_tot, n_me_old, n_me_new
integer :: i, j
type(state_matrix_t), pointer :: state_new, state_old
type(quantum_numbers_t), dimension(:), allocatable :: qn
logical :: matched
logical, dimension(size (qn_mask)) :: dropped
integer :: ndropped
integer, dimension(:), allocatable :: inotdropped
type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
logical, dimension(:), allocatable :: resonant
eval%type = EVAL_QN_SUM
eval%int_in1 => int
nullify (eval%int_in2)
if (present (drop)) then
dropped = drop
else
dropped = .false.
end if
ndropped = count (dropped)
n_in = int%get_n_in ()
n_out = int%get_n_out () - ndropped
n_vir = int%get_n_vir ()
n_tot = int%get_n_tot () - ndropped
allocate (inotdropped (n_tot))
i = 1
do j = 1, n_tot + ndropped
if (dropped (j)) cycle
inotdropped(i) = j
i = i + 1
end do
allocate (mask(n_tot + ndropped))
mask = int%get_mask ()
allocate (resonant(n_tot + ndropped))
resonant = int%get_resonance_flags ()
call eval%interaction_t%basic_init (n_in, n_vir, n_out, &
mask = mask(inotdropped) .or. qn_mask(inotdropped), &
resonant = resonant(inotdropped))
i = 1
do j = 1, n_tot + ndropped
if (dropped(j)) cycle
call eval%set_source_link (i, int, j)
i = i + 1
end do
allocate (map(n_tot + ndropped))
i = 1
do j = 1, n_tot + ndropped
if (dropped (j)) then
map(j) = 0
else
map(j) = i
i = i + 1
end if
end do
call int%transfer_relations (eval, map)
n_me_old = int%get_n_matrix_elements ()
allocate (pairing_size (n_me_old), source = 0)
allocate (pairing_target (n_me_old), source = 0)
pairing_size = 0
state_old => int%get_state_matrix_ptr ()
state_new => eval%get_state_matrix_ptr ()
call it_old%init (state_old)
allocate (qn(n_tot + ndropped))
do while (it_old%is_valid ())
qn = it_old%get_quantum_numbers ()
if (.not. all (qn%are_diagonal ())) then
call it_old%advance ()
cycle
end if
matched = .false.
call it_new%init (state_new)
if (eval%get_n_matrix_elements () > 0) then
do while (it_new%is_valid ())
if (all (qn(inotdropped) .match. &
it_new%get_quantum_numbers ())) &
then
matched = .true.
i = it_new%get_me_index ()
exit
end if
call it_new%advance ()
end do
end if
if (.not. matched) then
call eval%add_state (qn(inotdropped))
i = eval%get_n_matrix_elements ()
end if
pairing_size(i) = pairing_size(i) + 1
pairing_target(it_old%get_me_index ()) = i
call it_old%advance ()
end do
call eval%freeze ()
n_me_new = eval%get_n_matrix_elements ()
allocate (eval%pairing_array (n_me_new))
do i = 1, n_me_new
call pairing_array_init (eval%pairing_array(i), &
pairing_size(i), .false., .false.)
end do
allocate (i_new (n_me_new), source = 0)
do i = 1, n_me_old
j = pairing_target(i)
if (j > 0) then
i_new(j) = i_new(j) + 1
eval%pairing_array(j)%i1(i_new(j)) = i
end if
end do
end subroutine evaluator_init_qn_sum
@ %def evaluator_init_qn_sum
@
\subsection{Evaluation}
When the input interactions (which are pointed to in the pairings
stored within the evaluator) are filled with values, we can activate
the evaluator, i.e., calculate the result values which are stored in
the interaction.
The evaluation of matrix elements can be done in parallel. A
[[forall]] construct is not appropriate, however. We would need
[[do concurrent]] here. Nevertheless, the evaluation functions are
marked as [[pure]].
<<Evaluators: evaluator: TBP>>=
procedure :: evaluate => evaluator_evaluate
<<Evaluators: sub interfaces>>=
module subroutine evaluator_evaluate (eval)
class(evaluator_t), intent(inout), target :: eval
end subroutine evaluator_evaluate
<<Evaluators: procedures>>=
module subroutine evaluator_evaluate (eval)
class(evaluator_t), intent(inout), target :: eval
integer :: i
select case (eval%type)
case (EVAL_PRODUCT)
do i = 1, size(eval%pairing_array)
call eval%evaluate_product (i, &
eval%int_in1, eval%int_in2, &
eval%pairing_array(i)%i1, eval%pairing_array(i)%i2)
if (debug2_active (D_QFT)) then
print *, 'eval%pairing_array(i)%i1, eval%pairing_array(i)%i2 = ', &
eval%pairing_array(i)%i1, eval%pairing_array(i)%i2
print *, 'MEs = ', &
eval%int_in1%get_matrix_element (eval%pairing_array(i)%i1), &
eval%int_in2%get_matrix_element (eval%pairing_array(i)%i2)
end if
end do
case (EVAL_SQUARE_WITH_COLOR_FACTORS)
do i = 1, size(eval%pairing_array)
call eval%evaluate_product_cf (i, &
eval%int_in1, eval%int_in1, &
eval%pairing_array(i)%i1, eval%pairing_array(i)%i2, &
eval%pairing_array(i)%factor)
end do
case (EVAL_SQUARED_FLOWS)
do i = 1, size(eval%pairing_array)
call eval%evaluate_square_c (i, &
eval%int_in1, &
eval%pairing_array(i)%i1)
end do
case (EVAL_COLOR_CONTRACTION)
do i = 1, size(eval%pairing_array)
call eval%evaluate_sum (i, &
eval%int_in1, &
eval%pairing_array(i)%i1)
end do
case (EVAL_IDENTITY)
call eval%set_matrix_element (eval%int_in1)
case (EVAL_QN_SUM)
do i = 1, size (eval%pairing_array)
call eval%evaluate_me_sum (i, &
eval%int_in1, eval%pairing_array(i)%i1)
call eval%set_norm (eval%int_in1%get_norm ())
end do
end select
end subroutine evaluator_evaluate
@ %def evaluator_evaluate
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[evaluators_ut.f90]]>>=
<<File header>>
module evaluators_ut
use unit_tests
use evaluators_uti
<<Standard module head>>
<<Evaluators: public test>>
contains
<<Evaluators: test driver>>
end module evaluators_ut
@ %def evaluators_ut
@
<<[[evaluators_uti.f90]]>>=
<<File header>>
module evaluators_uti
<<Use kinds>>
use lorentz
use flavors
use colors
use helicities
use quantum_numbers
use interactions
use model_data
use evaluators
<<Standard module head>>
<<Evaluators: test declarations>>
contains
<<Evaluators: tests>>
end module evaluators_uti
@ %def evaluators_ut
@ API: driver for the unit tests below.
<<Evaluators: public test>>=
public :: evaluator_test
<<Evaluators: test driver>>=
subroutine evaluator_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Evaluators: execute tests>>
end subroutine evaluator_test
@ %def evaluator_test
@ Test: Create two interactions. The interactions are twofold
connected. The first connection has a helicity index that is kept,
the second connection has a helicity index that is summed over.
Concatenate the interactions in an evaluator, which thus contains a
result interaction. Fill the input interactions with values, activate
the evaluator and print the result.
<<Evaluators: execute tests>>=
call test (evaluator_1, "evaluator_1", &
"check evaluators (1)", &
u, results)
<<Evaluators: test declarations>>=
public :: evaluator_1
<<Evaluators: tests>>=
subroutine evaluator_1 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(interaction_t), target :: int_qqtt, int_tbw, int1, int2
type(flavor_t), dimension(:), allocatable :: flv
type(color_t), dimension(:), allocatable :: col
type(helicity_t), dimension(:), allocatable :: hel
type(quantum_numbers_t), dimension(:), allocatable :: qn
integer :: f, c, h1, h2, h3
type(vector4_t), dimension(4) :: p
type(vector4_t), dimension(2) :: q
type(quantum_numbers_mask_t) :: qn_mask_conn
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask2
type(evaluator_t), target :: eval, eval2, eval3
call model%init_sm_test ()
write (u, "(A)") "*** Evaluator for matrix product"
write (u, "(A)") "*** Construct interaction for qq -> tt"
write (u, "(A)")
call int_qqtt%basic_init (2, 0, 2, set_relations=.true.)
allocate (flv (4), col (4), hel (4), qn (4))
allocate (qn_mask2 (4))
do c = 1, 2
select case (c)
case (1)
call col%init_col_acl ([1, 0, 1, 0], [0, 2, 0, 2])
case (2)
call col%init_col_acl ([1, 0, 2, 0], [0, 1, 0, 2])
end select
do f = 1, 2
call flv%init ([f, -f, 6, -6], model)
do h1 = -1, 1, 2
call hel(3)%init (h1)
do h2 = -1, 1, 2
call hel(4)%init (h2)
call qn%init (flv, col, hel)
call int_qqtt%add_state (qn)
end do
end do
end do
end do
call int_qqtt%freeze ()
deallocate (flv, col, hel, qn)
write (u, "(A)") "*** Construct interaction for t -> bW"
call int_tbw%basic_init (1, 0, 2, set_relations=.true.)
allocate (flv (3), col (3), hel (3), qn (3))
call flv%init ([6, 5, 24], model)
call col%init_col_acl ([1, 1, 0], [0, 0, 0])
do h1 = -1, 1, 2
call hel(1)%init (h1)
do h2 = -1, 1, 2
call hel(2)%init (h2)
do h3 = -1, 1
call hel(3)%init (h3)
call qn%init (flv, col, hel)
call int_tbw%add_state (qn)
end do
end do
end do
call int_tbw%freeze ()
deallocate (flv, col, hel, qn)
write (u, "(A)") "*** Link interactions"
call int_tbw%set_source_link (1, int_qqtt, 3)
qn_mask_conn = quantum_numbers_mask (.false.,.false.,.true.)
write (u, "(A)")
write (u, "(A)") "*** Show input"
call int_qqtt%basic_write (unit = u)
write (u, "(A)")
call int_tbw%basic_write (unit = u)
write (u, "(A)")
write (u, "(A)") "*** Evaluate product"
call eval%init_product (int_qqtt, int_tbw, qn_mask_conn)
call eval%write (unit = u)
call int1%basic_init (2, 0, 2, set_relations=.true.)
call int2%basic_init (1, 0, 2, set_relations=.true.)
p(1) = vector4_moving (1000._default, 1000._default, 3)
p(2) = vector4_moving (200._default, 200._default, 2)
p(3) = vector4_moving (100._default, 200._default, 1)
p(4) = p(1) - p(2) - p(3)
call int1%set_momenta (p)
q(1) = vector4_moving (50._default,-50._default, 3)
q(2) = p(2) + p(4) - q(1)
call int2%set_momenta (q, outgoing=.true.)
call int1%set_matrix_element ([(2._default,0._default), &
(4._default,1._default), (-3._default,0._default)])
call int2%set_matrix_element ([(-3._default,0._default), &
(0._default,1._default), (1._default,2._default)])
call eval%receive_momenta ()
call eval%evaluate ()
call int1%basic_write (unit = u)
write (u, "(A)")
call int2%basic_write (unit = u)
write (u, "(A)")
call eval%write (unit = u)
write (u, "(A)")
call int1%final ()
call int2%final ()
call eval%final ()
write (u, "(A)")
write (u, "(A)") "*** Evaluator for matrix square"
allocate (flv(4), col(4), qn(4))
call int1%basic_init (2, 0, 2, set_relations=.true.)
call flv%init ([1, -1, 21, 21], model)
call col(1)%init ([1])
call col(2)%init ([-2])
call col(3)%init ([2, -3])
call col(4)%init ([3, -1])
call qn%init (flv, col)
call int1%add_state (qn)
call col(3)%init ([3, -1])
call col(4)%init ([2, -3])
call qn%init (flv, col)
call int1%add_state (qn)
call col(3)%init ([2, -1])
call col(4)%init (.true.)
call qn%init (flv, col)
call int1%add_state (qn)
call int1%freeze ()
! [qn_mask2 not set since default is false]
call eval%init_square (int1, qn_mask2, nc=3)
call eval2%init_square_nondiag (int1, qn_mask2)
qn_mask2 = quantum_numbers_mask (.false., .true., .true.)
call eval3%init_square_diag (eval, qn_mask2)
call int1%set_matrix_element &
([(2._default,0._default), &
(4._default,1._default), (-3._default,0._default)])
call int1%set_momenta (p)
call int1%basic_write (unit = u)
write (u, "(A)")
call eval%receive_momenta ()
call eval%evaluate ()
call eval%write (unit = u)
write (u, "(A)")
call eval2%receive_momenta ()
call eval2%evaluate ()
call eval2%write (unit = u)
write (u, "(A)")
call eval3%receive_momenta ()
call eval3%evaluate ()
call eval3%write (unit = u)
call int1%final ()
call eval%final ()
call eval2%final ()
call eval3%final ()
call model%final ()
end subroutine evaluator_1
@ %def evaluator_1
@
<<Evaluators: execute tests>>=
call test (evaluator_2, "evaluator_2", &
"check evaluators (2)", &
u, results)
<<Evaluators: test declarations>>=
public :: evaluator_2
<<Evaluators: tests>>=
subroutine evaluator_2 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(interaction_t), target :: int
integer :: h1, h2, h3, h4
type(helicity_t), dimension(4) :: hel
type(color_t), dimension(4) :: col
type(flavor_t), dimension(4) :: flv
type(quantum_numbers_t), dimension(4) :: qn
type(vector4_t), dimension(4) :: p
type(evaluator_t) :: eval
integer :: i
call model%init_sm_test ()
write (u, "(A)") "*** Creating interaction for e+ e- -> W+ W-"
write (u, "(A)")
call flv%init ([11, -11, 24, -24], model)
do i = 1, 4
call col(i)%init ()
end do
call int%basic_init (2, 0, 2, set_relations=.true.)
do h1 = -1, 1, 2
call hel(1)%init (h1)
do h2 = -1, 1, 2
call hel(2)%init (h2)
do h3 = -1, 1
call hel(3)%init (h3)
do h4 = -1, 1
call hel(4)%init (h4)
call qn%init (flv, col, hel)
call int%add_state (qn)
end do
end do
end do
end do
call int%freeze ()
call int%set_matrix_element &
([(cmplx (i, kind=default), i = 1, 36)])
p(1) = vector4_moving (1000._default, 1000._default, 3)
p(2) = vector4_moving (1000._default, -1000._default, 3)
p(3) = vector4_moving (1000._default, &
sqrt (1E6_default - 80._default**2), 3)
p(4) = p(1) + p(2) - p(3)
call int%set_momenta (p)
write (u, "(A)") "*** Setting up evaluator"
write (u, "(A)")
call eval%init_identity (int)
write (u, "(A)") "*** Transferring momenta and evaluating"
write (u, "(A)")
call eval%receive_momenta ()
call eval%evaluate ()
write (u, "(A)") "*******************************************************"
write (u, "(A)") " Interaction dump"
write (u, "(A)") "*******************************************************"
call int%basic_write (unit = u)
write (u, "(A)")
write (u, "(A)") "*******************************************************"
write (u, "(A)") " Evaluator dump"
write (u, "(A)") "*******************************************************"
call eval%write (unit = u)
write (u, "(A)")
write (u, "(A)") "*** cleaning up"
call int%final ()
call eval%final ()
call model%final ()
end subroutine evaluator_2
@ %def evaluator_2
@
<<Evaluators: execute tests>>=
call test (evaluator_3, "evaluator_3", &
"check evaluators (3)", &
u, results)
<<Evaluators: test declarations>>=
public :: evaluator_3
<<Evaluators: tests>>=
subroutine evaluator_3 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(interaction_t), target :: int
integer :: h1, h2, h3, h4
type(helicity_t), dimension(4) :: hel
type(color_t), dimension(4) :: col
type(flavor_t), dimension(4) :: flv1, flv2
type(quantum_numbers_t), dimension(4) :: qn
type(vector4_t), dimension(4) :: p
type(evaluator_t) :: eval1, eval2, eval3
type(quantum_numbers_mask_t), dimension(4) :: qn_mask
integer :: i
call model%init_sm_test ()
write (u, "(A)") "*** Creating interaction for e+/mu+ e-/mu- -> W+ W-"
call flv1%init ([11, -11, 24, -24], model)
call flv2%init ([13, -13, 24, -24], model)
do i = 1, 4
call col (i)%init ()
end do
call int%basic_init (2, 0, 2, set_relations=.true.)
do h1 = -1, 1, 2
call hel(1)%init (h1)
do h2 = -1, 1, 2
call hel(2)%init (h2)
do h3 = -1, 1
call hel(3)%init (h3)
do h4 = -1, 1
call hel(4)%init (h4)
call qn%init (flv1, col, hel)
call int%add_state (qn)
call qn%init (flv2, col, hel)
call int%add_state (qn)
end do
end do
end do
end do
call int%freeze ()
call int%set_matrix_element &
([(cmplx (1, kind=default), i = 1, 72)])
p(1) = vector4_moving (1000._default, 1000._default, 3)
p(2) = vector4_moving (1000._default, -1000._default, 3)
p(3) = vector4_moving (1000._default, &
sqrt (1E6_default - 80._default**2), 3)
p(4) = p(1) + p(2) - p(3)
call int%set_momenta (p)
write (u, "(A)") "*** Setting up evaluators"
call qn_mask%init (.false., .true., .true.)
call eval1%init_qn_sum (int, qn_mask)
call qn_mask%init (.true., .true., .true.)
call eval2%init_qn_sum (int, qn_mask)
call qn_mask%init (.false., .true., .false.)
call eval3%init_qn_sum (int, qn_mask, &
[.false., .false., .false., .true.])
write (u, "(A)") "*** Transferring momenta and evaluating"
call eval1%receive_momenta ()
call eval1%evaluate ()
call eval2%receive_momenta ()
call eval2%evaluate ()
call eval3%receive_momenta ()
call eval3%evaluate ()
write (u, "(A)") "*******************************************************"
write (u, "(A)") " Interaction dump"
write (u, "(A)") "*******************************************************"
call int%basic_write (unit = u)
write (u, "(A)")
write (u, "(A)") "*******************************************************"
write (u, "(A)") " Evaluator dump --- spin sum"
write (u, "(A)") "*******************************************************"
call eval1%write (unit = u)
call eval1%basic_write (unit = u)
write (u, "(A)") "*******************************************************"
write (u, "(A)") " Evaluator dump --- spin / flavor sum"
write (u, "(A)") "*******************************************************"
call eval2%write (unit = u)
call eval2%basic_write (unit = u)
write (u, "(A)") "*******************************************************"
write (u, "(A)") " Evaluator dump --- flavor sum, drop last W"
write (u, "(A)") "*******************************************************"
call eval3%write (unit = u)
call eval3%basic_write (unit = u)
write (u, "(A)")
write (u, "(A)") "*** cleaning up"
call int%final ()
call eval1%final ()
call eval2%final ()
call eval3%final ()
call model%final ()
end subroutine evaluator_3
@ %def evaluator_3
@ This test evaluates a product with different quantum-number masks and
filters for the linked entry.
<<Evaluators: execute tests>>=
call test (evaluator_4, "evaluator_4", &
"check evaluator product with filter", &
u, results)
<<Evaluators: test declarations>>=
public :: evaluator_4
<<Evaluators: tests>>=
subroutine evaluator_4 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(interaction_t), target :: int1, int2
integer :: h1, h2, h3
type(helicity_t), dimension(3) :: hel
type(color_t), dimension(3) :: col
type(flavor_t), dimension(2) :: flv1, flv2
type(flavor_t), dimension(3) :: flv3, flv4
type(quantum_numbers_t), dimension(3) :: qn
type(evaluator_t) :: eval1, eval2, eval3, eval4
type(quantum_numbers_mask_t) :: qn_mask
type(flavor_t) :: flv_filter
type(helicity_t) :: hel_filter
type(color_t) :: col_filter
type(quantum_numbers_t) :: qn_filter
integer :: i
write (u, "(A)") "* Test output: evaluator_4"
write (u, "(A)") "* Purpose: test evaluator products &
&with mask and filter"
write (u, "(A)")
call model%init_sm_test ()
write (u, "(A)") "* Creating interaction for e- -> W+/Z"
write (u, "(A)")
call flv1%init ([11, 24], model)
call flv2%init ([11, 23], model)
do i = 1, 3
call col(i)%init ()
end do
call int1%basic_init (1, 0, 1, set_relations=.true.)
do h1 = -1, 1, 2
call hel(1)%init (h1)
do h2 = -1, 1
call hel(2)%init (h2)
call qn(:2)%init (flv1, col(:2), hel(:2))
call int1%add_state (qn(:2))
call qn(:2)%init (flv2, col(:2), hel(:2))
call int1%add_state (qn(:2))
end do
end do
call int1%freeze ()
call int1%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Creating interaction for W+/Z -> u ubar/dbar"
write (u, "(A)")
call flv3%init ([24, 2, -1], model)
call flv4%init ([23, 2, -2], model)
call int2%basic_init (1, 0, 2, set_relations=.true.)
do h1 = -1, 1
call hel(1)%init (h1)
do h2 = -1, 1, 2
call hel(2)%init (h2)
do h3 = -1, 1, 2
call hel(3)%init (h3)
call qn(:3)%init (flv3, col(:3), hel(:3))
call int2%add_state (qn(:3))
call qn(:3)%init (flv4, col(:3), hel(:3))
call int2%add_state (qn(:3))
end do
end do
end do
call int2%freeze ()
call int2%set_source_link (1, int1, 2)
call int2%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Product evaluator"
write (u, "(A)")
call qn_mask%init (.false., .false., .false.)
call eval1%init_product (int1, int2, qn_mask_conn = qn_mask)
call eval1%write (u)
write (u, "(A)")
write (u, "(A)") "* Product evaluator with helicity mask"
write (u, "(A)")
call qn_mask%init (.false., .false., .true.)
call eval2%init_product (int1, int2, qn_mask_conn = qn_mask)
call eval2%write (u)
write (u, "(A)")
write (u, "(A)") "* Product with flavor filter and helicity mask"
write (u, "(A)")
call qn_mask%init (.false., .false., .true.)
call flv_filter%init (24, model)
call hel_filter%init ()
call col_filter%init ()
call qn_filter%init (flv_filter, col_filter, hel_filter)
call eval3%init_product (int1, int2, &
qn_mask_conn = qn_mask, qn_filter_conn = qn_filter)
call eval3%write (u)
write (u, "(A)")
write (u, "(A)") "* Product with helicity filter and mask"
write (u, "(A)")
call qn_mask%init (.false., .false., .true.)
call flv_filter%init ()
call hel_filter%init (0)
call col_filter%init ()
call qn_filter%init (flv_filter, col_filter, hel_filter)
call eval4%init_product (int1, int2, &
qn_mask_conn = qn_mask, qn_filter_conn = qn_filter)
call eval4%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eval1%final ()
call eval2%final ()
call eval3%final ()
call eval4%final ()
call int1%final ()
call int2%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: evaluator_4"
end subroutine evaluator_4
@ %def evaluator_4
Index: trunk/src/whizard-core/whizard.nw
===================================================================
--- trunk/src/whizard-core/whizard.nw (revision 8842)
+++ trunk/src/whizard-core/whizard.nw (revision 8843)
@@ -1,31820 +1,31823 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD main code as NOWEB source
\includemodulegraph{whizard-core}
\chapter{Integration and Simulation}
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{User-controlled File I/O}
The SINDARIN language includes commands that write output to file (input may
be added later). We identify files by their name, and manage the unit
internally. We need procedures for opening, closing, and printing files.
<<[[user_files.f90]]>>=
<<File header>>
module user_files
<<Use strings>>
use ifiles
<<Standard module head>>
<<User files: public>>
<<User files: types>>
<<User files: interfaces>>
interface
<<User files: sub interfaces>>
end interface
end module user_files
@ %def user_files
@
<<[[user_files_sub.f90]]>>=
<<File header>>
submodule (user_files) user_files_s
use io_units
use diagnostics
use analysis
implicit none
contains
<<User files: procedures>>
end submodule user_files_s
@ %def user_files_s
@
\subsection{The file type}
This is a type that describes an open user file and its properties. The entry
is part of a doubly-linked list.
<<User files: types>>=
type :: file_t
private
type(string_t) :: name
integer :: unit = -1
logical :: reading = .false.
logical :: writing = .false.
type(file_t), pointer :: prev => null ()
type(file_t), pointer :: next => null ()
end type file_t
@ %def file_t
@ The initializer opens the file.
<<User files: procedures>>=
subroutine file_init (file, name, action, status, position)
type(file_t), intent(out) :: file
type(string_t), intent(in) :: name
character(len=*), intent(in) :: action, status, position
file%unit = free_unit ()
file%name = name
open (unit = file%unit, file = char (file%name), &
action = action, status = status, position = position)
select case (action)
case ("read")
file%reading = .true.
case ("write")
file%writing = .true.
case ("readwrite")
file%reading = .true.
file%writing = .true.
end select
end subroutine file_init
@ %def file_init
@ The finalizer closes it.
<<User files: procedures>>=
subroutine file_final (file)
type(file_t), intent(inout) :: file
close (unit = file%unit)
file%unit = -1
end subroutine file_final
@ %def file_final
@ Check if a file is open with correct status.
<<User files: procedures>>=
function file_is_open (file, action) result (flag)
logical :: flag
type(file_t), intent(in) :: file
character(*), intent(in) :: action
select case (action)
case ("read")
flag = file%reading
case ("write")
flag = file%writing
case ("readwrite")
flag = file%reading .and. file%writing
case default
call msg_bug ("Checking file '" // char (file%name) &
// "': illegal action specifier")
end select
end function file_is_open
@ %def file_is_open
@ Return the unit number of a file for direct access. It should be checked
first whether the file is open.
<<User files: procedures>>=
function file_get_unit (file) result (unit)
integer :: unit
type(file_t), intent(in) :: file
unit = file%unit
end function file_get_unit
@ %def file_get_unit
@ Write to the file. Error if in wrong mode. If there is no string, just
write an empty record. If there is a string, respect the [[advancing]]
option.
<<User files: procedures>>=
subroutine file_write_string (file, string, advancing)
type(file_t), intent(in) :: file
type(string_t), intent(in), optional :: string
logical, intent(in), optional :: advancing
if (file%writing) then
if (present (string)) then
if (present (advancing)) then
if (advancing) then
write (file%unit, "(A)") char (string)
else
write (file%unit, "(A)", advance="no") char (string)
end if
else
write (file%unit, "(A)") char (string)
end if
else
write (file%unit, *)
end if
else
call msg_error ("Writing to file: File '" // char (file%name) &
// "' is not open for writing.")
end if
end subroutine file_write_string
@ %def file_write
@ Write a whole ifile, line by line.
<<User files: procedures>>=
subroutine file_write_ifile (file, ifile)
type(file_t), intent(in) :: file
type(ifile_t), intent(in) :: ifile
type(line_p) :: line
call line_init (line, ifile)
do while (line_is_associated (line))
call file_write_string (file, line_get_string_advance (line))
end do
end subroutine file_write_ifile
@ %def file_write_ifile
@ Write an analysis object (or all objects) to an open file.
<<User files: procedures>>=
subroutine file_write_analysis (file, tag)
type(file_t), intent(in) :: file
type(string_t), intent(in), optional :: tag
if (file%writing) then
if (present (tag)) then
call analysis_write (tag, unit = file%unit)
else
call analysis_write (unit = file%unit)
end if
else
call msg_error ("Writing analysis to file: File '" // char (file%name) &
// "' is not open for writing.")
end if
end subroutine file_write_analysis
@ %def file_write_analysis
@
\subsection{The file list}
We maintain a list of all open files and their attributes. The list must be
doubly-linked because we may delete entries.
<<User files: public>>=
public :: file_list_t
<<User files: types>>=
type :: file_list_t
type(file_t), pointer :: first => null ()
type(file_t), pointer :: last => null ()
end type file_list_t
@ %def file_list_t
@ There is no initialization routine, but a finalizer which deletes all:
<<User files: public>>=
public :: file_list_final
<<User files: sub interfaces>>=
module subroutine file_list_final (file_list)
type(file_list_t), intent(inout) :: file_list
end subroutine file_list_final
<<User files: procedures>>=
module subroutine file_list_final (file_list)
type(file_list_t), intent(inout) :: file_list
type(file_t), pointer :: current
do while (associated (file_list%first))
current => file_list%first
file_list%first => current%next
call file_final (current)
deallocate (current)
end do
file_list%last => null ()
end subroutine file_list_final
@ %def file_list_final
@ Find an entry in the list. Return null pointer on failure.
<<User files: procedures>>=
function file_list_get_file_ptr (file_list, name) result (current)
type(file_t), pointer :: current
type(file_list_t), intent(in) :: file_list
type(string_t), intent(in) :: name
current => file_list%first
do while (associated (current))
if (current%name == name) return
current => current%next
end do
end function file_list_get_file_ptr
@ %def file_list_get_file_ptr
@ Check if a file is open, public version:
<<User files: public>>=
public :: file_list_is_open
<<User files: sub interfaces>>=
module function file_list_is_open (file_list, name, action) result (flag)
logical :: flag
type(file_list_t), intent(in) :: file_list
type(string_t), intent(in) :: name
character(len=*), intent(in) :: action
end function file_list_is_open
<<User files: procedures>>=
module function file_list_is_open (file_list, name, action) result (flag)
logical :: flag
type(file_list_t), intent(in) :: file_list
type(string_t), intent(in) :: name
character(len=*), intent(in) :: action
type(file_t), pointer :: current
current => file_list_get_file_ptr (file_list, name)
if (associated (current)) then
flag = file_is_open (current, action)
else
flag = .false.
end if
end function file_list_is_open
@ %def file_list_is_open
@ Return the unit number for a file. It should be checked first whether the
file is open.
<<User files: public>>=
public :: file_list_get_unit
<<User files: sub interfaces>>=
module function file_list_get_unit (file_list, name) result (unit)
integer :: unit
type(file_list_t), intent(in) :: file_list
type(string_t), intent(in) :: name
end function file_list_get_unit
<<User files: procedures>>=
module function file_list_get_unit (file_list, name) result (unit)
integer :: unit
type(file_list_t), intent(in) :: file_list
type(string_t), intent(in) :: name
type(file_t), pointer :: current
current => file_list_get_file_ptr (file_list, name)
if (associated (current)) then
unit = file_get_unit (current)
else
unit = -1
end if
end function file_list_get_unit
@ %def file_list_get_unit
@ Append a new file entry, i.e., open this file. Error if it is
already open.
<<User files: public>>=
public :: file_list_open
<<User files: sub interfaces>>=
module subroutine file_list_open (file_list, name, action, status, position)
type(file_list_t), intent(inout) :: file_list
type(string_t), intent(in) :: name
character(len=*), intent(in) :: action, status, position
end subroutine file_list_open
<<User files: procedures>>=
module subroutine file_list_open (file_list, name, action, status, position)
type(file_list_t), intent(inout) :: file_list
type(string_t), intent(in) :: name
character(len=*), intent(in) :: action, status, position
type(file_t), pointer :: current
if (.not. associated (file_list_get_file_ptr (file_list, name))) then
allocate (current)
call msg_message ("Opening file '" // char (name) // "' for output")
call file_init (current, name, action, status, position)
if (associated (file_list%last)) then
file_list%last%next => current
current%prev => file_list%last
else
file_list%first => current
end if
file_list%last => current
else
call msg_error ("Opening file: File '" // char (name) &
// "' is already open.")
end if
end subroutine file_list_open
@ %def file_list_open
@ Delete a file entry, i.e., close this file. Error if it is not open.
<<User files: public>>=
public :: file_list_close
<<User files: sub interfaces>>=
module subroutine file_list_close (file_list, name)
type(file_list_t), intent(inout) :: file_list
type(string_t), intent(in) :: name
end subroutine file_list_close
<<User files: procedures>>=
module subroutine file_list_close (file_list, name)
type(file_list_t), intent(inout) :: file_list
type(string_t), intent(in) :: name
type(file_t), pointer :: current
current => file_list_get_file_ptr (file_list, name)
if (associated (current)) then
if (associated (current%prev)) then
current%prev%next => current%next
else
file_list%first => current%next
end if
if (associated (current%next)) then
current%next%prev => current%prev
else
file_list%last => current%prev
end if
call msg_message ("Closing file '" // char (name) // "' for output")
call file_final (current)
deallocate (current)
else
call msg_error ("Closing file: File '" // char (name) &
// "' is not open.")
end if
end subroutine file_list_close
@ %def file_list_close
@ Write a string to file. Error if it is not open.
<<User files: public>>=
public :: file_list_write
<<User files: interfaces>>=
interface file_list_write
module procedure file_list_write_string
module procedure file_list_write_ifile
end interface
<<User files: sub interfaces>>=
module subroutine file_list_write_ifile (file_list, name, ifile)
type(file_list_t), intent(in) :: file_list
type(string_t), intent(in) :: name
type(ifile_t), intent(in) :: ifile
end subroutine file_list_write_ifile
module subroutine file_list_write_string &
(file_list, name, string, advancing)
type(file_list_t), intent(in) :: file_list
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: string
logical, intent(in), optional :: advancing
end subroutine file_list_write_string
<<User files: procedures>>=
module subroutine file_list_write_string (file_list, name, string, advancing)
type(file_list_t), intent(in) :: file_list
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: string
logical, intent(in), optional :: advancing
type(file_t), pointer :: current
current => file_list_get_file_ptr (file_list, name)
if (associated (current)) then
call file_write_string (current, string, advancing)
else
call msg_error ("Writing to file: File '" // char (name) &
// "'is not open.")
end if
end subroutine file_list_write_string
module subroutine file_list_write_ifile (file_list, name, ifile)
type(file_list_t), intent(in) :: file_list
type(string_t), intent(in) :: name
type(ifile_t), intent(in) :: ifile
type(file_t), pointer :: current
current => file_list_get_file_ptr (file_list, name)
if (associated (current)) then
call file_write_ifile (current, ifile)
else
call msg_error ("Writing to file: File '" // char (name) &
// "'is not open.")
end if
end subroutine file_list_write_ifile
@ %def file_list_write
@ Write an analysis object or all objects to data file. Error if it is not
open. If the file name is empty, write to standard output.
<<User files: public>>=
public :: file_list_write_analysis
<<User files: sub interfaces>>=
module subroutine file_list_write_analysis (file_list, name, tag)
type(file_list_t), intent(in) :: file_list
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: tag
end subroutine file_list_write_analysis
<<User files: procedures>>=
module subroutine file_list_write_analysis (file_list, name, tag)
type(file_list_t), intent(in) :: file_list
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: tag
type(file_t), pointer :: current
if (name == "") then
if (present (tag)) then
call analysis_write (tag)
else
call analysis_write
end if
else
current => file_list_get_file_ptr (file_list, name)
if (associated (current)) then
call file_write_analysis (current, tag)
else
call msg_error ("Writing analysis to file: File '" // char (name) &
// "' is not open.")
end if
end if
end subroutine file_list_write_analysis
@ %def file_list_write_analysis
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Runtime data}
<<[[rt_data.f90]]>>=
<<File header>>
module rt_data
<<Use kinds>>
<<Use strings>>
use os_interface
use lexers
use parser
use models
use subevents
use pdg_arrays
use variables, only: var_list_t
use process_libraries
use prclib_stacks
use prc_core, only: helicity_selection_t
use beam_structures
use event_base, only: event_callback_t
use user_files
use process_stacks
use iterations
<<Standard module head>>
<<RT data: public>>
<<RT data: types>>
interface
<<RT data: sub interfaces>>
end interface
contains
<<RT data: main procedures>>
end module rt_data
@ %def rt_data
@
<<[[rt_data_sub.f90]]>>=
<<File header>>
submodule (rt_data) rt_data_s
use io_units
use format_utils, only: write_separator
use format_defs, only: FMT_19, FMT_12
use system_dependencies
use diagnostics
implicit none
contains
<<RT data: procedures>>
end submodule rt_data_s
@ %def rt_data_s
@
\subsection{Strategy for models and variables}
The program manages its data via a main [[rt_data_t]] object. During program
flow, various commands create and use local [[rt_data_t]] objects. Those
transient blocks contain either pointers to global object or local copies
which are deleted after use.
Each [[rt_data_t]] object contains a variable list component. This lists
holds (local copies of) all kinds of intrinsic or user-defined variables. The
variable list is linked to the variable list contained in the local process
library. This, in turn, is linked to the variable list of the [[rt_data_t]]
context, and so on.
A variable lookup will thus be recursively delegated to the linked variable
lists, until a match is found. When modifying a variable which is not yet
local, the program creates a local copy and uses this afterwards. Thus, when
the local [[rt_data_t]] object is deleted, the context value is recovered.
Models are kept in a model list which is separate from the variable list.
Otherwise, they are treated in a similar manner: the local list is linked to
the context model list. Model lookup is thus recursively delegated. When a
model or any part of it is modified, the model is copied to the local
[[rt_data_t]] object, so the context model is not modified. Commands such as
[[integrate]] will create their own copy of the current model (and of the
current variable list) at the point where they are executed.
When a model is encountered for the first time, it is read from file. The
reading is automatically delegated to the global context. Thus, this master
copy survives until the main [[rt_data_t]] object is deleted, at program
completion.
If there is a currently active model, its variable list is linked to the main
variable list. Variable lookups will then start from the model variable
list. When the current model is switched, the new active model will get this
link instead. Consequently, a change to the current model is kept as long as
this model has a local copy; it survives local model switches. On the other
hand, a parameter change in the current model doesn't affect any other model,
even if the parameter name is identical.
@
\subsection{Container for parse nodes}
The runtime data set contains a bunch of parse nodes (chunks of code
that have not been compiled into evaluation trees but saved for later
use). We collect them here.
This implementation has the useful effect that an assignment between two
objects of this type will establish a pointer-target relationship for
all components.
<<RT data: types>>=
type :: rt_parse_nodes_t
type(parse_node_t), pointer :: cuts_lexpr => null ()
type(parse_node_t), pointer :: scale_expr => null ()
type(parse_node_t), pointer :: fac_scale_expr => null ()
type(parse_node_t), pointer :: ren_scale_expr => null ()
type(parse_node_t), pointer :: weight_expr => null ()
type(parse_node_t), pointer :: selection_lexpr => null ()
type(parse_node_t), pointer :: reweight_expr => null ()
type(parse_node_t), pointer :: analysis_lexpr => null ()
type(parse_node_p), dimension(:), allocatable :: alt_setup
contains
<<RT data: rt parse nodes: TBP>>
end type rt_parse_nodes_t
@ %def rt_parse_nodes_t
@ Clear individual components. The parse nodes are nullified. No
finalization needed since the pointer targets are part of the global
parse tree.
<<RT data: rt parse nodes: TBP>>=
procedure :: clear => rt_parse_nodes_clear
<<RT data: sub interfaces>>=
module subroutine rt_parse_nodes_clear (rt_pn, name)
class(rt_parse_nodes_t), intent(inout) :: rt_pn
type(string_t), intent(in) :: name
end subroutine rt_parse_nodes_clear
<<RT data: procedures>>=
module subroutine rt_parse_nodes_clear (rt_pn, name)
class(rt_parse_nodes_t), intent(inout) :: rt_pn
type(string_t), intent(in) :: name
select case (char (name))
case ("cuts")
rt_pn%cuts_lexpr => null ()
case ("scale")
rt_pn%scale_expr => null ()
case ("factorization_scale")
rt_pn%fac_scale_expr => null ()
case ("renormalization_scale")
rt_pn%ren_scale_expr => null ()
case ("weight")
rt_pn%weight_expr => null ()
case ("selection")
rt_pn%selection_lexpr => null ()
case ("reweight")
rt_pn%reweight_expr => null ()
case ("analysis")
rt_pn%analysis_lexpr => null ()
end select
end subroutine rt_parse_nodes_clear
@ %def rt_parse_nodes_clear
@ Output for the parse nodes.
<<RT data: rt parse nodes: TBP>>=
procedure :: write => rt_parse_nodes_write
<<RT data: sub interfaces>>=
module subroutine rt_parse_nodes_write (object, unit)
class(rt_parse_nodes_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine rt_parse_nodes_write
<<RT data: procedures>>=
module subroutine rt_parse_nodes_write (object, unit)
class(rt_parse_nodes_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
call wrt ("Cuts", object%cuts_lexpr)
call write_separator (u)
call wrt ("Scale", object%scale_expr)
call write_separator (u)
call wrt ("Factorization scale", object%fac_scale_expr)
call write_separator (u)
call wrt ("Renormalization scale", object%ren_scale_expr)
call write_separator (u)
call wrt ("Weight", object%weight_expr)
call write_separator (u, 2)
call wrt ("Event selection", object%selection_lexpr)
call write_separator (u)
call wrt ("Event reweighting factor", object%reweight_expr)
call write_separator (u)
call wrt ("Event analysis", object%analysis_lexpr)
if (allocated (object%alt_setup)) then
call write_separator (u, 2)
write (u, "(1x,A,':')") "Alternative setups"
do i = 1, size (object%alt_setup)
call write_separator (u)
call wrt ("Commands", object%alt_setup(i)%ptr)
end do
end if
contains
subroutine wrt (title, pn)
character(*), intent(in) :: title
type(parse_node_t), intent(in), pointer :: pn
if (associated (pn)) then
write (u, "(1x,A,':')") title
call write_separator (u)
call parse_node_write_rec (pn, u)
else
write (u, "(1x,A,':',1x,A)") title, "[undefined]"
end if
end subroutine wrt
end subroutine rt_parse_nodes_write
@ %def rt_parse_nodes_write
@ Screen output for individual components. (This should eventually be more
condensed, currently we print the internal representation tree.)
<<RT data: rt parse nodes: TBP>>=
procedure :: show => rt_parse_nodes_show
<<RT data: sub interfaces>>=
module subroutine rt_parse_nodes_show (rt_pn, name, unit)
class(rt_parse_nodes_t), intent(in) :: rt_pn
type(string_t), intent(in) :: name
integer, intent(in), optional :: unit
end subroutine rt_parse_nodes_show
<<RT data: procedures>>=
module subroutine rt_parse_nodes_show (rt_pn, name, unit)
class(rt_parse_nodes_t), intent(in) :: rt_pn
type(string_t), intent(in) :: name
integer, intent(in), optional :: unit
type(parse_node_t), pointer :: pn
integer :: u
u = given_output_unit (unit)
select case (char (name))
case ("cuts")
pn => rt_pn%cuts_lexpr
case ("scale")
pn => rt_pn%scale_expr
case ("factorization_scale")
pn => rt_pn%fac_scale_expr
case ("renormalization_scale")
pn => rt_pn%ren_scale_expr
case ("weight")
pn => rt_pn%weight_expr
case ("selection")
pn => rt_pn%selection_lexpr
case ("reweight")
pn => rt_pn%reweight_expr
case ("analysis")
pn => rt_pn%analysis_lexpr
end select
if (associated (pn)) then
write (u, "(A,1x,A,1x,A)") "Expression:", char (name), "(parse tree):"
call parse_node_write_rec (pn, u)
else
write (u, "(A,1x,A,A)") "Expression:", char (name), ": [undefined]"
end if
end subroutine rt_parse_nodes_show
@ %def rt_parse_nodes_show
@
\subsection{The data type}
This is a big data container which contains everything that is used and
modified during the command flow. A local copy of this can be used to
temporarily override defaults. The data set is transparent.
<<RT data: public>>=
public :: rt_data_t
<<RT data: types>>=
type :: rt_data_t
type(lexer_t), pointer :: lexer => null ()
type(rt_data_t), pointer :: context => null ()
type(string_t), dimension(:), allocatable :: export
type(var_list_t) :: var_list
type(iterations_list_t) :: it_list
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(model_t), pointer :: model => null ()
logical :: model_is_copy = .false.
type(model_t), pointer :: preload_model => null ()
type(model_t), pointer :: fallback_model => null ()
type(prclib_stack_t) :: prclib_stack
type(process_library_t), pointer :: prclib => null ()
type(beam_structure_t) :: beam_structure
type(rt_parse_nodes_t) :: pn
type(process_stack_t) :: process_stack
type(string_t), dimension(:), allocatable :: sample_fmt
class(event_callback_t), allocatable :: event_callback
type(file_list_t), pointer :: out_files => null ()
logical :: quit = .false.
integer :: quit_code = 0
type(string_t) :: logfile
logical :: nlo_fixed_order = .false.
logical, dimension(0:5) :: selected_nlo_parts = .false.
integer, dimension(:), allocatable :: nlo_component
contains
<<RT data: rt data: TBP>>
end type rt_data_t
@ %def rt_data_t
@
\subsection{Output}
<<RT data: rt data: TBP>>=
procedure :: write => rt_data_write
<<RT data: sub interfaces>>=
module subroutine rt_data_write (object, unit, vars, pacify)
class(rt_data_t), intent(in) :: object
integer, intent(in), optional :: unit
type(string_t), dimension(:), intent(in), optional :: vars
logical, intent(in), optional :: pacify
end subroutine rt_data_write
<<RT data: procedures>>=
module subroutine rt_data_write (object, unit, vars, pacify)
class(rt_data_t), intent(in) :: object
integer, intent(in), optional :: unit
type(string_t), dimension(:), intent(in), optional :: vars
logical, intent(in), optional :: pacify
integer :: u, i
u = given_output_unit (unit)
call write_separator (u, 2)
write (u, "(1x,A)") "Runtime data:"
if (object%get_n_export () > 0) then
call write_separator (u, 2)
write (u, "(1x,A)") "Exported objects and variables:"
call write_separator (u)
call object%write_exports (u)
end if
if (present (vars)) then
if (size (vars) /= 0) then
call write_separator (u, 2)
write (u, "(1x,A)") "Selected variables:"
call write_separator (u)
call object%write_vars (u, vars)
end if
else
call write_separator (u, 2)
if (associated (object%model)) then
call object%model%write_var_list (u, follow_link=.true.)
else
call object%var_list%write (u, follow_link=.true.)
end if
end if
if (object%it_list%get_n_pass () > 0) then
call write_separator (u, 2)
write (u, "(1x)", advance="no")
call object%it_list%write (u)
end if
if (associated (object%model)) then
call write_separator (u, 2)
call object%model%write (u)
end if
call object%prclib_stack%write (u)
call object%beam_structure%write (u)
call write_separator (u, 2)
call object%pn%write (u)
if (allocated (object%sample_fmt)) then
call write_separator (u)
write (u, "(1x,A)", advance="no") "Event sample formats = "
do i = 1, size (object%sample_fmt)
if (i > 1) write (u, "(A,1x)", advance="no") ","
write (u, "(A)", advance="no") char (object%sample_fmt(i))
end do
write (u, "(A)")
end if
call write_separator (u)
write (u, "(1x,A)", advance="no") "Event callback:"
if (allocated (object%event_callback)) then
call object%event_callback%write (u)
else
write (u, "(1x,A)") "[undefined]"
end if
call object%process_stack%write (u, pacify)
write (u, "(1x,A,1x,L1)") "quit :", object%quit
write (u, "(1x,A,1x,I0)") "quit_code:", object%quit_code
call write_separator (u, 2)
write (u, "(1x,A,1x,A)") "Logfile :", "'" // trim (char (object%logfile)) // "'"
call write_separator (u, 2)
end subroutine rt_data_write
@ %def rt_data_write
@ Write only selected variables.
<<RT data: rt data: TBP>>=
procedure :: write_vars => rt_data_write_vars
<<RT data: sub interfaces>>=
module subroutine rt_data_write_vars (object, unit, vars)
class(rt_data_t), intent(in), target :: object
integer, intent(in), optional :: unit
type(string_t), dimension(:), intent(in) :: vars
end subroutine rt_data_write_vars
<<RT data: procedures>>=
module subroutine rt_data_write_vars (object, unit, vars)
class(rt_data_t), intent(in), target :: object
integer, intent(in), optional :: unit
type(string_t), dimension(:), intent(in) :: vars
type(var_list_t), pointer :: var_list
integer :: u, i
u = given_output_unit (unit)
var_list => object%get_var_list_ptr ()
do i = 1, size (vars)
associate (var => vars(i))
if (var_list%contains (var, follow_link=.true.)) then
call var_list%write_var (var, unit = u, &
follow_link = .true., defined=.true.)
end if
end associate
end do
end subroutine rt_data_write_vars
@ %def rt_data_write_vars
@ Write only the model list.
<<RT data: rt data: TBP>>=
procedure :: write_model_list => rt_data_write_model_list
<<RT data: sub interfaces>>=
module subroutine rt_data_write_model_list (object, unit)
class(rt_data_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine rt_data_write_model_list
<<RT data: procedures>>=
module subroutine rt_data_write_model_list (object, unit)
class(rt_data_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
call object%model_list%write (u)
end subroutine rt_data_write_model_list
@ %def rt_data_write_model_list
@ Write only the library stack.
<<RT data: rt data: TBP>>=
procedure :: write_libraries => rt_data_write_libraries
<<RT data: sub interfaces>>=
module subroutine rt_data_write_libraries (object, unit, libpath)
class(rt_data_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: libpath
end subroutine rt_data_write_libraries
<<RT data: procedures>>=
module subroutine rt_data_write_libraries (object, unit, libpath)
class(rt_data_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: libpath
integer :: u
u = given_output_unit (unit)
call object%prclib_stack%write (u, libpath)
end subroutine rt_data_write_libraries
@ %def rt_data_write_libraries
@ Write only the beam data.
<<RT data: rt data: TBP>>=
procedure :: write_beams => rt_data_write_beams
<<RT data: sub interfaces>>=
module subroutine rt_data_write_beams (object, unit)
class(rt_data_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine rt_data_write_beams
<<RT data: procedures>>=
module subroutine rt_data_write_beams (object, unit)
class(rt_data_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
call write_separator (u, 2)
call object%beam_structure%write (u)
call write_separator (u, 2)
end subroutine rt_data_write_beams
@ %def rt_data_write_beams
@ Write only the process and event expressions.
<<RT data: rt data: TBP>>=
procedure :: write_expr => rt_data_write_expr
<<RT data: sub interfaces>>=
module subroutine rt_data_write_expr (object, unit)
class(rt_data_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine rt_data_write_expr
<<RT data: procedures>>=
module subroutine rt_data_write_expr (object, unit)
class(rt_data_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
call write_separator (u, 2)
call object%pn%write (u)
call write_separator (u, 2)
end subroutine rt_data_write_expr
@ %def rt_data_write_expr
@ Write only the process stack.
<<RT data: rt data: TBP>>=
procedure :: write_process_stack => rt_data_write_process_stack
<<RT data: sub interfaces>>=
module subroutine rt_data_write_process_stack (object, unit)
class(rt_data_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine rt_data_write_process_stack
<<RT data: procedures>>=
module subroutine rt_data_write_process_stack (object, unit)
class(rt_data_t), intent(in) :: object
integer, intent(in), optional :: unit
call object%process_stack%write (unit)
end subroutine rt_data_write_process_stack
@ %def rt_data_write_process_stack
@
<<RT data: rt data: TBP>>=
procedure :: write_var_descriptions => rt_data_write_var_descriptions
<<RT data: sub interfaces>>=
module subroutine rt_data_write_var_descriptions &
(rt_data, unit, ascii_output)
class(rt_data_t), intent(in) :: rt_data
integer, intent(in), optional :: unit
logical, intent(in), optional :: ascii_output
end subroutine rt_data_write_var_descriptions
<<RT data: procedures>>=
module subroutine rt_data_write_var_descriptions (rt_data, unit, ascii_output)
class(rt_data_t), intent(in) :: rt_data
integer, intent(in), optional :: unit
logical, intent(in), optional :: ascii_output
integer :: u
logical :: ao
u = given_output_unit (unit)
ao = .false.; if (present (ascii_output)) ao = ascii_output
call rt_data%var_list%write (u, follow_link=.true., &
descriptions=.true., ascii_output=ao)
end subroutine rt_data_write_var_descriptions
@ %def rt_data_write_var_descriptions
@
<<RT data: rt data: TBP>>=
procedure :: show_description_of_string => rt_data_show_description_of_string
<<RT data: sub interfaces>>=
module subroutine rt_data_show_description_of_string (rt_data, string, &
unit, ascii_output)
class(rt_data_t), intent(in) :: rt_data
type(string_t), intent(in) :: string
integer, intent(in), optional :: unit
logical, intent(in), optional :: ascii_output
end subroutine rt_data_show_description_of_string
<<RT data: procedures>>=
module subroutine rt_data_show_description_of_string (rt_data, string, &
unit, ascii_output)
class(rt_data_t), intent(in) :: rt_data
type(string_t), intent(in) :: string
integer, intent(in), optional :: unit
logical, intent(in), optional :: ascii_output
integer :: u
logical :: ao
u = given_output_unit (unit)
ao = .false.; if (present (ascii_output)) ao = ascii_output
call rt_data%var_list%write_var (string, unit=u, follow_link=.true., &
defined=.false., descriptions=.true., ascii_output=ao)
end subroutine rt_data_show_description_of_string
@ %def rt_data_show_description_of_string
@
\subsection{Clear}
The [[clear]] command can remove the contents of various subobjects.
The objects themselves should stay.
<<RT data: rt data: TBP>>=
procedure :: clear_beams => rt_data_clear_beams
<<RT data: sub interfaces>>=
module subroutine rt_data_clear_beams (global)
class(rt_data_t), intent(inout) :: global
end subroutine rt_data_clear_beams
<<RT data: procedures>>=
module subroutine rt_data_clear_beams (global)
class(rt_data_t), intent(inout) :: global
call global%beam_structure%final_sf ()
call global%beam_structure%final_pol ()
call global%beam_structure%final_mom ()
end subroutine rt_data_clear_beams
@ %def rt_data_clear_beams
@
\subsection{Initialization}
Initialize runtime data. This defines special variables such as
[[sqrts]], and should be done only for the instance that is actually
global. Local copies will inherit the special variables.
We link the global variable list to the process stack variable list,
so the latter is always available (and kept global).
<<RT data: rt data: TBP>>=
procedure :: global_init => rt_data_global_init
<<RT data: sub interfaces>>=
module subroutine rt_data_global_init (global, paths, logfile)
class(rt_data_t), intent(out), target :: global
type(paths_t), intent(in), optional :: paths
type(string_t), intent(in), optional :: logfile
end subroutine rt_data_global_init
<<RT data: procedures>>=
module subroutine rt_data_global_init (global, paths, logfile)
class(rt_data_t), intent(out), target :: global
type(paths_t), intent(in), optional :: paths
type(string_t), intent(in), optional :: logfile
integer :: seed
call global%os_data%init (paths)
if (present (logfile)) then
global%logfile = logfile
else
global%logfile = ""
end if
allocate (global%out_files)
call system_clock (seed)
call global%var_list%init_defaults (seed, paths)
call global%init_pointer_variables ()
call global%process_stack%init_var_list (global%var_list)
end subroutine rt_data_global_init
@ %def rt_data_global_init
@
\subsection{Local copies}
This is done at compile time when a local copy of runtime data is
needed: Link the variable list and initialize all derived parameters.
This allows for synchronizing them with local variable changes without
affecting global data.
Also re-initialize pointer variables, so they point to local copies of
their targets.
<<RT data: rt data: TBP>>=
procedure :: local_init => rt_data_local_init
<<RT data: sub interfaces>>=
module subroutine rt_data_local_init (local, global, env)
class(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(in), target :: global
integer, intent(in), optional :: env
end subroutine rt_data_local_init
<<RT data: procedures>>=
module subroutine rt_data_local_init (local, global, env)
class(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(in), target :: global
integer, intent(in), optional :: env
local%context => global
call local%process_stack%link (global%process_stack)
call local%process_stack%init_var_list (local%var_list)
call local%process_stack%link_var_list (global%var_list)
call local%var_list%append_string (var_str ("$model_name"), &
var_str (""), intrinsic=.true.)
call local%init_pointer_variables ()
local%fallback_model => global%fallback_model
local%os_data = global%os_data
local%logfile = global%logfile
call local%model_list%link (global%model_list)
local%model => global%model
if (associated (local%model)) then
call local%model%link_var_list (local%var_list)
end if
if (allocated (global%event_callback)) then
allocate (local%event_callback, source = global%event_callback)
end if
end subroutine rt_data_local_init
@ %def rt_data_local_init
@ These variables point to objects which get local copies:
<<RT data: rt data: TBP>>=
procedure :: init_pointer_variables => rt_data_init_pointer_variables
<<RT data: sub interfaces>>=
module subroutine rt_data_init_pointer_variables (local)
class(rt_data_t), intent(inout), target :: local
end subroutine rt_data_init_pointer_variables
<<RT data: procedures>>=
module subroutine rt_data_init_pointer_variables (local)
class(rt_data_t), intent(inout), target :: local
logical, target, save :: known = .true.
call local%var_list%append_string_ptr (var_str ("$fc"), &
local%os_data%fc, known, intrinsic=.true., &
description=var_str('This string variable gives the ' // &
'\ttt{Fortran} compiler used within \whizard. It can ' // &
'only be accessed, not set by the user. (cf. also ' // &
'\ttt{\$fcflags}, \ttt{\$fclibs})'))
call local%var_list%append_string_ptr (var_str ("$fcflags"), &
local%os_data%fcflags, known, intrinsic=.true., &
description=var_str('This string variable gives the ' // &
'compiler flags for the \ttt{Fortran} compiler used ' // &
'within \whizard. It can only be accessed, not set by ' // &
'the user. (cf. also \ttt{\$fc}, \ttt{\$fclibs})'))
call local%var_list%append_string_ptr (var_str ("$fclibs"), &
local%os_data%fclibs, known, intrinsic=.true., &
description=var_str('This string variable gives the ' // &
'linked libraries for the \ttt{Fortran} compiler used ' // &
'within \whizard. It can only be accessed, not set by ' // &
'the user. (cf. also \ttt{\$fc}, \ttt{\$fcflags})'))
end subroutine rt_data_init_pointer_variables
@ %def rt_data_init_pointer_variables
@ This is done at execution time: Copy data, transfer pointers.
[[local]] has intent(inout) because its local variable list has
already been prepared by the previous routine.
To be pedantic, the local pointers to model and library should point
to the entries in the local copies. (However, as long as these are
just shallow copies with identical content, this is actually
irrelevant.)
The process library and process stacks behave as global objects. The
copies of the process library and process stacks should be shallow
copies, so the contents stay identical. Since objects may be pushed
on the stack in the local environment, upon restoring the global
environment, we should reverse the assignment. Then the added stack
elements will end up on the global stack. (This should be
reconsidered in a parallel environment.)
Gfortran 7/8/9 bug, has to remain in the main module:
<<RT data: rt data: TBP>>=
procedure :: activate => rt_data_activate
<<RT data: main procedures>>=
subroutine rt_data_activate (local)
class(rt_data_t), intent(inout), target :: local
class(rt_data_t), pointer :: global
global => local%context
if (associated (global)) then
local%lexer => global%lexer
call global%copy_globals (local)
local%os_data = global%os_data
local%logfile = global%logfile
if (associated (global%prclib)) then
local%prclib => &
local%prclib_stack%get_library_ptr (global%prclib%get_name ())
end if
call local%import_values ()
call local%process_stack%link (global%process_stack)
local%it_list = global%it_list
local%beam_structure = global%beam_structure
local%pn = global%pn
if (allocated (local%sample_fmt)) deallocate (local%sample_fmt)
if (allocated (global%sample_fmt)) then
allocate (local%sample_fmt (size (global%sample_fmt)), &
source = global%sample_fmt)
end if
local%out_files => global%out_files
local%model => global%model
local%model_is_copy = .false.
else if (.not. associated (local%model)) then
local%model => local%preload_model
local%model_is_copy = .false.
end if
if (associated (local%model)) then
call local%model%link_var_list (local%var_list)
call local%var_list%set_string (var_str ("$model_name"), &
local%model%get_name (), is_known = .true.)
else
call local%var_list%set_string (var_str ("$model_name"), &
var_str (""), is_known = .false.)
end if
end subroutine rt_data_activate
@ %def rt_data_activate
@ Restore the previous state of data, without actually finalizing the local
environment. We also clear the local process stack. Some local modifications
(model list and process library stack) are communicated to the global context,
if there is any.
If the [[keep_local]] flag is set, we want to retain current settings in
the local environment. In particular, we create an instance of the currently
selected model (which thus becomes separated from the model library!).
The local variables are also kept.
<<RT data: rt data: TBP>>=
procedure :: deactivate => rt_data_deactivate
<<RT data: sub interfaces>>=
module subroutine rt_data_deactivate (local, global, keep_local)
class(rt_data_t), intent(inout), target :: local
class(rt_data_t), intent(inout), optional, target :: global
logical, intent(in), optional :: keep_local
end subroutine rt_data_deactivate
<<RT data: procedures>>=
module subroutine rt_data_deactivate (local, global, keep_local)
class(rt_data_t), intent(inout), target :: local
class(rt_data_t), intent(inout), optional, target :: global
logical, intent(in), optional :: keep_local
type(string_t) :: local_model, local_scheme
logical :: same_model, delete
delete = .true.; if (present (keep_local)) delete = .not. keep_local
if (present (global)) then
if (associated (global%model) .and. associated (local%model)) then
local_model = local%model%get_name ()
if (global%model%has_schemes ()) then
local_scheme = local%model%get_scheme ()
same_model = &
global%model%matches (local_model, local_scheme)
else
same_model = global%model%matches (local_model)
end if
else
same_model = .false.
end if
if (delete) then
call local%process_stack%clear ()
call local%unselect_model ()
call local%unset_values ()
else if (associated (local%model)) then
call local%ensure_model_copy ()
end if
if (.not. same_model .and. associated (global%model)) then
if (global%model%has_schemes ()) then
call msg_message ("Restoring model '" // &
char (global%model%get_name ()) // "', scheme '" // &
char (global%model%get_scheme ()) // "'")
else
call msg_message ("Restoring model '" // &
char (global%model%get_name ()) // "'")
end if
end if
if (associated (global%model)) then
call global%model%link_var_list (global%var_list)
end if
call global%restore_globals (local)
else
call local%unselect_model ()
end if
end subroutine rt_data_deactivate
@ %def rt_data_deactivate
@ This imports the global objects for which local modifications
should be kept. Currently, this is only the process library stack.
<<RT data: rt data: TBP>>=
procedure :: copy_globals => rt_data_copy_globals
<<RT data: sub interfaces>>=
module subroutine rt_data_copy_globals (global, local)
class(rt_data_t), intent(in) :: global
class(rt_data_t), intent(inout) :: local
end subroutine rt_data_copy_globals
<<RT data: procedures>>=
module subroutine rt_data_copy_globals (global, local)
class(rt_data_t), intent(in) :: global
class(rt_data_t), intent(inout) :: local
local%prclib_stack = global%prclib_stack
end subroutine rt_data_copy_globals
@ %def rt_data_copy_globals
@ This restores global objects for which local modifications
should be kept. May also modify (remove) the local objects.
<<RT data: rt data: TBP>>=
procedure :: restore_globals => rt_data_restore_globals
<<RT data: sub interfaces>>=
module subroutine rt_data_restore_globals (global, local)
class(rt_data_t), intent(inout) :: global
class(rt_data_t), intent(inout) :: local
end subroutine rt_data_restore_globals
<<RT data: procedures>>=
module subroutine rt_data_restore_globals (global, local)
class(rt_data_t), intent(inout) :: global
class(rt_data_t), intent(inout) :: local
global%prclib_stack = local%prclib_stack
call local%handle_exports (global)
end subroutine rt_data_restore_globals
@ %def rt_data_restore_globals
@
\subsection{Exported objects}
Exported objects are transferred to the global state when a local environment
is closed. (For the top-level global data set, there is no effect.)
The current implementation handles only the [[results]] object, which resolves
to the local process stack. The stack elements are appended to the global
stack without modification, the local stack becomes empty.
Write names of objects to be exported:
<<RT data: rt data: TBP>>=
procedure :: write_exports => rt_data_write_exports
<<RT data: sub interfaces>>=
module subroutine rt_data_write_exports (rt_data, unit)
class(rt_data_t), intent(in) :: rt_data
integer, intent(in), optional :: unit
end subroutine rt_data_write_exports
<<RT data: procedures>>=
module subroutine rt_data_write_exports (rt_data, unit)
class(rt_data_t), intent(in) :: rt_data
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
do i = 1, rt_data%get_n_export ()
write (u, "(A)") char (rt_data%export(i))
end do
end subroutine rt_data_write_exports
@ %def rt_data_write_exports
@ The number of entries in the export list.
<<RT data: rt data: TBP>>=
procedure :: get_n_export => rt_data_get_n_export
<<RT data: sub interfaces>>=
module function rt_data_get_n_export (rt_data) result (n)
class(rt_data_t), intent(in) :: rt_data
integer :: n
end function rt_data_get_n_export
<<RT data: procedures>>=
module function rt_data_get_n_export (rt_data) result (n)
class(rt_data_t), intent(in) :: rt_data
integer :: n
if (allocated (rt_data%export)) then
n = size (rt_data%export)
else
n = 0
end if
end function rt_data_get_n_export
@ %def rt_data_get_n_export
@ Return a specific export
@ Append new names to the export list. If a duplicate occurs, do not transfer
it.
<<RT data: rt data: TBP>>=
procedure :: append_exports => rt_data_append_exports
<<RT data: sub interfaces>>=
module subroutine rt_data_append_exports (rt_data, export)
class(rt_data_t), intent(inout) :: rt_data
type(string_t), dimension(:), intent(in) :: export
end subroutine rt_data_append_exports
<<RT data: procedures>>=
module subroutine rt_data_append_exports (rt_data, export)
class(rt_data_t), intent(inout) :: rt_data
type(string_t), dimension(:), intent(in) :: export
logical, dimension(:), allocatable :: mask
type(string_t), dimension(:), allocatable :: tmp
integer :: i, j, n
if (.not. allocated (rt_data%export)) allocate (rt_data%export (0))
n = size (rt_data%export)
allocate (mask (size (export)), source=.false.)
do i = 1, size (export)
mask(i) = all (export(i) /= rt_data%export) &
.and. all (export(i) /= export(:i-1))
end do
if (count (mask) > 0) then
allocate (tmp (n + count (mask)))
tmp(1:n) = rt_data%export(:)
j = n
do i = 1, size (export)
if (mask(i)) then
j = j + 1
tmp(j) = export(i)
end if
end do
call move_alloc (from=tmp, to=rt_data%export)
end if
end subroutine rt_data_append_exports
@ %def rt_data_append_exports
@ Transfer export-objects from the [[local]] rt data to the [[global]] rt
data, as far as supported.
<<RT data: rt data: TBP>>=
procedure :: handle_exports => rt_data_handle_exports
<<RT data: sub interfaces>>=
module subroutine rt_data_handle_exports (local, global)
class(rt_data_t), intent(inout), target :: local
class(rt_data_t), intent(inout), target :: global
end subroutine rt_data_handle_exports
<<RT data: procedures>>=
module subroutine rt_data_handle_exports (local, global)
class(rt_data_t), intent(inout), target :: local
class(rt_data_t), intent(inout), target :: global
type(string_t) :: export
integer :: i
if (local%get_n_export () > 0) then
do i = 1, local%get_n_export ()
export = local%export(i)
select case (char (export))
case ("results")
call msg_message ("Exporting integration results &
&to outer environment")
call local%transfer_process_stack (global)
case default
call msg_bug ("handle exports: '" &
// char (export) // "' unsupported")
end select
end do
end if
end subroutine rt_data_handle_exports
@ %def rt_data_handle_exports
@ Export the process stack. One-by-one, take the last process from the local
stack and push it on the global stack. Also handle the corresponding result
variables: append if the process did not exist yet in the global stack,
otherwise update.
TODO: result variables do not work that way yet, require initialization in the
global variable list.
<<RT data: rt data: TBP>>=
procedure :: transfer_process_stack => rt_data_transfer_process_stack
<<RT data: sub interfaces>>=
module subroutine rt_data_transfer_process_stack (local, global)
class(rt_data_t), intent(inout), target :: local
class(rt_data_t), intent(inout), target :: global
end subroutine rt_data_transfer_process_stack
<<RT data: procedures>>=
module subroutine rt_data_transfer_process_stack (local, global)
class(rt_data_t), intent(inout), target :: local
class(rt_data_t), intent(inout), target :: global
type(process_entry_t), pointer :: process
type(string_t) :: process_id
do
call local%process_stack%pop_last (process)
if (.not. associated (process)) exit
process_id = process%get_id ()
call global%process_stack%push (process)
call global%process_stack%fill_result_vars (process_id)
call global%process_stack%update_result_vars &
(process_id, global%var_list)
end do
end subroutine rt_data_transfer_process_stack
@ %def rt_data_transfer_process_stack
@
\subsection{Finalization}
Finalizer for the variable list and the structure-function list.
This is done only for the global RT dataset; local copies contain
pointers to this and do not need a finalizer.
<<RT data: rt data: TBP>>=
procedure :: final => rt_data_global_final
<<RT data: sub interfaces>>=
module subroutine rt_data_global_final (global)
class(rt_data_t), intent(inout) :: global
end subroutine rt_data_global_final
<<RT data: procedures>>=
module subroutine rt_data_global_final (global)
class(rt_data_t), intent(inout) :: global
call global%process_stack%final ()
call global%prclib_stack%final ()
call global%model_list%final ()
call global%var_list%final (follow_link=.false.)
if (associated (global%out_files)) then
call file_list_final (global%out_files)
deallocate (global%out_files)
end if
end subroutine rt_data_global_final
@ %def rt_data_global_final
@ The local copy needs a finalizer for the variable list, which consists
of local copies. This finalizer is called only when the local
environment is finally discarded. (Note that the process stack should
already have been cleared after execution, which can occur many times
for the same local environment.)
<<RT data: rt data: TBP>>=
procedure :: local_final => rt_data_local_final
<<RT data: sub interfaces>>=
module subroutine rt_data_local_final (local)
class(rt_data_t), intent(inout) :: local
end subroutine rt_data_local_final
<<RT data: procedures>>=
module subroutine rt_data_local_final (local)
class(rt_data_t), intent(inout) :: local
call local%process_stack%clear ()
call local%model_list%final ()
call local%var_list%final (follow_link=.false.)
end subroutine rt_data_local_final
@ %def rt_data_local_final
@
\subsection{Model Management}
Read a model, so it becomes available for activation. No variables or model
copies, this is just initialization.
If this is a local environment, the model will be automatically read into the
global context.
<<RT data: rt data: TBP>>=
procedure :: read_model => rt_data_read_model
<<RT data: sub interfaces>>=
module subroutine rt_data_read_model (global, name, model, scheme)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: scheme
type(model_t), pointer, intent(out) :: model
end subroutine rt_data_read_model
<<RT data: procedures>>=
module subroutine rt_data_read_model (global, name, model, scheme)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: scheme
type(model_t), pointer, intent(out) :: model
type(string_t) :: filename
filename = name // ".mdl"
call global%model_list%read_model &
(name, filename, global%os_data, model, scheme)
end subroutine rt_data_read_model
@ %def rt_data_read_model
@ Read a UFO model. Create it on the fly if necessary.
<<RT data: rt data: TBP>>=
procedure :: read_ufo_model => rt_data_read_ufo_model
<<RT data: sub interfaces>>=
module subroutine rt_data_read_ufo_model (global, name, model, ufo_path)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
type(model_t), pointer, intent(out) :: model
type(string_t), intent(in), optional :: ufo_path
end subroutine rt_data_read_ufo_model
<<RT data: procedures>>=
module subroutine rt_data_read_ufo_model (global, name, model, ufo_path)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
type(model_t), pointer, intent(out) :: model
type(string_t), intent(in), optional :: ufo_path
type(string_t) :: filename
filename = name // ".ufo.mdl"
call global%model_list%read_model &
(name, filename, global%os_data, model, ufo=.true., ufo_path=ufo_path)
end subroutine rt_data_read_ufo_model
@ %def rt_data_read_ufo_model
@ Initialize the fallback model. This model is used
whenever the current model does not describe all physical particles
(hadrons, mainly). It is not supposed to be modified, and the pointer
should remain linked to this model.
<<RT data: rt data: TBP>>=
procedure :: init_fallback_model => rt_data_init_fallback_model
<<RT data: sub interfaces>>=
module subroutine rt_data_init_fallback_model (global, name, filename)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name, filename
end subroutine rt_data_init_fallback_model
<<RT data: procedures>>=
module subroutine rt_data_init_fallback_model (global, name, filename)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name, filename
call global%model_list%read_model &
(name, filename, global%os_data, global%fallback_model)
end subroutine rt_data_init_fallback_model
@ %def rt_data_init_fallback_model
@
Activate a model: assign the current-model pointer and set the model name in
the variable list. If necessary, read the model from file. Link the global
variable list to the model variable list.
<<RT data: rt data: TBP>>=
procedure :: select_model => rt_data_select_model
<<RT data: sub interfaces>>=
module subroutine rt_data_select_model (global, name, scheme, ufo, ufo_path)
class(rt_data_t), intent(inout), target :: global
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: scheme
logical, intent(in), optional :: ufo
type(string_t), intent(in), optional :: ufo_path
end subroutine rt_data_select_model
<<RT data: procedures>>=
module subroutine rt_data_select_model (global, name, scheme, ufo, ufo_path)
class(rt_data_t), intent(inout), target :: global
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: scheme
logical, intent(in), optional :: ufo
type(string_t), intent(in), optional :: ufo_path
logical :: same_model, ufo_model
ufo_model = .false.; if (present (ufo)) ufo_model = ufo
if (associated (global%model)) then
same_model = global%model%matches (name, scheme, ufo)
else
same_model = .false.
end if
if (.not. same_model) then
global%model => global%model_list%get_model_ptr (name, scheme, ufo)
if (.not. associated (global%model)) then
if (ufo_model) then
call global%read_ufo_model (name, global%model, ufo_path)
else
call global%read_model (name, global%model)
end if
global%model_is_copy = .false.
else if (associated (global%context)) then
global%model_is_copy = &
global%model_list%model_exists (name, scheme, ufo, &
follow_link=.false.)
else
global%model_is_copy = .false.
end if
end if
if (associated (global%model)) then
call global%model%link_var_list (global%var_list)
call global%var_list%set_string (var_str ("$model_name"), &
name, is_known = .true.)
if (global%model%is_ufo_model ()) then
call msg_message ("Switching to model '" // char (name) // "' " &
// "(generated from UFO source)")
else if (global%model%has_schemes ()) then
call msg_message ("Switching to model '" // char (name) // "', " &
// "scheme '" // char (global%model%get_scheme ()) // "'")
else
call msg_message ("Switching to model '" // char (name) // "'")
end if
else
call global%var_list%set_string (var_str ("$model_name"), &
var_str (""), is_known = .false.)
end if
end subroutine rt_data_select_model
@ %def rt_data_select_model
@
Remove the model link. Do not unset the model name variable, because
this may unset the variable in a parent [[rt_data]] object (via linked
var lists).
<<RT data: rt data: TBP>>=
procedure :: unselect_model => rt_data_unselect_model
<<RT data: sub interfaces>>=
module subroutine rt_data_unselect_model (global)
class(rt_data_t), intent(inout), target :: global
end subroutine rt_data_unselect_model
<<RT data: procedures>>=
module subroutine rt_data_unselect_model (global)
class(rt_data_t), intent(inout), target :: global
if (associated (global%model)) then
global%model => null ()
global%model_is_copy = .false.
end if
end subroutine rt_data_unselect_model
@ %def rt_data_unselect_model
@
Create a copy of the currently selected model and append it to the local model
list. The model pointer is redirected to the copy.
(Not applicable for the global model list, those models will be
modified in-place.)
<<RT data: rt data: TBP>>=
procedure :: ensure_model_copy => rt_data_ensure_model_copy
<<RT data: sub interfaces>>=
module subroutine rt_data_ensure_model_copy (global)
class(rt_data_t), intent(inout), target :: global
end subroutine rt_data_ensure_model_copy
<<RT data: procedures>>=
module subroutine rt_data_ensure_model_copy (global)
class(rt_data_t), intent(inout), target :: global
if (associated (global%context)) then
if (.not. global%model_is_copy) then
call global%model_list%append_copy (global%model, global%model)
global%model_is_copy = .true.
call global%model%link_var_list (global%var_list)
end if
end if
end subroutine rt_data_ensure_model_copy
@ %def rt_data_ensure_model_copy
@
Modify a model variable. The update mechanism will ensure that the model
parameter set remains consistent. This has to take place in a local copy
of the current model. If there is none yet, create one.
<<RT data: rt data: TBP>>=
procedure :: model_set_real => rt_data_model_set_real
<<RT data: sub interfaces>>=
module subroutine rt_data_model_set_real &
(global, name, rval, verbose, pacified)
class(rt_data_t), intent(inout), target :: global
type(string_t), intent(in) :: name
real(default), intent(in) :: rval
logical, intent(in), optional :: verbose, pacified
end subroutine rt_data_model_set_real
<<RT data: procedures>>=
module subroutine rt_data_model_set_real &
(global, name, rval, verbose, pacified)
class(rt_data_t), intent(inout), target :: global
type(string_t), intent(in) :: name
real(default), intent(in) :: rval
logical, intent(in), optional :: verbose, pacified
call global%ensure_model_copy ()
call global%model%set_real (name, rval, verbose, pacified)
end subroutine rt_data_model_set_real
@ %def rt_data_model_set_real
@
Modify particle properties. This has to take place in a local copy
of the current model. If there is none yet, create one.
<<RT data: rt data: TBP>>=
procedure :: modify_particle => rt_data_modify_particle
<<RT data: sub interfaces>>=
module subroutine rt_data_modify_particle &
(global, pdg, polarized, stable, decay, &
isotropic_decay, diagonal_decay, decay_helicity)
class(rt_data_t), intent(inout), target :: global
integer, intent(in) :: pdg
logical, intent(in), optional :: polarized, stable
logical, intent(in), optional :: isotropic_decay, diagonal_decay
integer, intent(in), optional :: decay_helicity
type(string_t), dimension(:), intent(in), optional :: decay
end subroutine rt_data_modify_particle
<<RT data: procedures>>=
module subroutine rt_data_modify_particle &
(global, pdg, polarized, stable, decay, &
isotropic_decay, diagonal_decay, decay_helicity)
class(rt_data_t), intent(inout), target :: global
integer, intent(in) :: pdg
logical, intent(in), optional :: polarized, stable
logical, intent(in), optional :: isotropic_decay, diagonal_decay
integer, intent(in), optional :: decay_helicity
type(string_t), dimension(:), intent(in), optional :: decay
call global%ensure_model_copy ()
if (present (polarized)) then
if (polarized) then
call global%model%set_polarized (pdg)
else
call global%model%set_unpolarized (pdg)
end if
end if
if (present (stable)) then
if (stable) then
call global%model%set_stable (pdg)
else if (present (decay)) then
call global%model%set_unstable &
(pdg, decay, isotropic_decay, diagonal_decay, decay_helicity)
else
call msg_bug ("Setting particle unstable: missing decay processes")
end if
end if
end subroutine rt_data_modify_particle
@ %def rt_data_modify_particle
@
\subsection{Managing Variables}
Return a pointer to the currently active variable list. If there is no model,
this is the global variable list. If there is one, it is the model variable
list, which should be linked to the former.
<<RT data: rt data: TBP>>=
procedure :: get_var_list_ptr => rt_data_get_var_list_ptr
<<RT data: sub interfaces>>=
module function rt_data_get_var_list_ptr (global) result (var_list)
class(rt_data_t), intent(in), target :: global
type(var_list_t), pointer :: var_list
end function rt_data_get_var_list_ptr
<<RT data: procedures>>=
module function rt_data_get_var_list_ptr (global) result (var_list)
class(rt_data_t), intent(in), target :: global
type(var_list_t), pointer :: var_list
if (associated (global%model)) then
var_list => global%model%get_var_list_ptr ()
else
var_list => global%var_list
end if
end function rt_data_get_var_list_ptr
@ %def rt_data_get_var_list_ptr
@ Initialize a local variable: append it to the current variable list. No
initial value, yet.
<<RT data: rt data: TBP>>=
procedure :: append_log => rt_data_append_log
procedure :: append_int => rt_data_append_int
procedure :: append_real => rt_data_append_real
procedure :: append_cmplx => rt_data_append_cmplx
procedure :: append_subevt => rt_data_append_subevt
procedure :: append_pdg_array => rt_data_append_pdg_array
procedure :: append_string => rt_data_append_string
<<RT data: sub interfaces>>=
module subroutine rt_data_append_log (local, name, lval, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
logical, intent(in), optional :: lval
logical, intent(in), optional :: intrinsic, user
end subroutine rt_data_append_log
module subroutine rt_data_append_int (local, name, ival, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
integer, intent(in), optional :: ival
logical, intent(in), optional :: intrinsic, user
end subroutine rt_data_append_int
module subroutine rt_data_append_real (local, name, rval, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
real(default), intent(in), optional :: rval
logical, intent(in), optional :: intrinsic, user
end subroutine rt_data_append_real
module subroutine rt_data_append_cmplx (local, name, cval, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
complex(default), intent(in), optional :: cval
logical, intent(in), optional :: intrinsic, user
end subroutine rt_data_append_cmplx
module subroutine rt_data_append_subevt (local, name, pval, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
type(subevt_t), intent(in), optional :: pval
logical, intent(in) :: intrinsic, user
end subroutine rt_data_append_subevt
module subroutine rt_data_append_pdg_array &
(local, name, aval, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
type(pdg_array_t), intent(in), optional :: aval
logical, intent(in), optional :: intrinsic, user
end subroutine rt_data_append_pdg_array
module subroutine rt_data_append_string (local, name, sval, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: sval
logical, intent(in), optional :: intrinsic, user
end subroutine rt_data_append_string
<<RT data: procedures>>=
module subroutine rt_data_append_log (local, name, lval, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
logical, intent(in), optional :: lval
logical, intent(in), optional :: intrinsic, user
call local%var_list%append_log (name, lval, &
intrinsic = intrinsic, user = user)
end subroutine rt_data_append_log
module subroutine rt_data_append_int (local, name, ival, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
integer, intent(in), optional :: ival
logical, intent(in), optional :: intrinsic, user
call local%var_list%append_int (name, ival, &
intrinsic = intrinsic, user = user)
end subroutine rt_data_append_int
module subroutine rt_data_append_real (local, name, rval, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
real(default), intent(in), optional :: rval
logical, intent(in), optional :: intrinsic, user
call local%var_list%append_real (name, rval, &
intrinsic = intrinsic, user = user)
end subroutine rt_data_append_real
module subroutine rt_data_append_cmplx (local, name, cval, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
complex(default), intent(in), optional :: cval
logical, intent(in), optional :: intrinsic, user
call local%var_list%append_cmplx (name, cval, &
intrinsic = intrinsic, user = user)
end subroutine rt_data_append_cmplx
module subroutine rt_data_append_subevt (local, name, pval, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
type(subevt_t), intent(in), optional :: pval
logical, intent(in) :: intrinsic, user
call local%var_list%append_subevt (name, &
intrinsic = intrinsic, user = user)
end subroutine rt_data_append_subevt
module subroutine rt_data_append_pdg_array &
(local, name, aval, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
type(pdg_array_t), intent(in), optional :: aval
logical, intent(in), optional :: intrinsic, user
call local%var_list%append_pdg_array (name, aval, &
intrinsic = intrinsic, user = user)
end subroutine rt_data_append_pdg_array
module subroutine rt_data_append_string (local, name, sval, intrinsic, user)
class(rt_data_t), intent(inout) :: local
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: sval
logical, intent(in), optional :: intrinsic, user
call local%var_list%append_string (name, sval, &
intrinsic = intrinsic, user = user)
end subroutine rt_data_append_string
@ %def rt_data_append_log
@ %def rt_data_append_int
@ %def rt_data_append_real
@ %def rt_data_append_cmplx
@ %def rt_data_append_subevt
@ %def rt_data_append_pdg_array
@ %def rt_data_append_string
@ Import values for all local variables, given a global context environment
where these variables are defined.
<<RT data: rt data: TBP>>=
procedure :: import_values => rt_data_import_values
<<RT data: sub interfaces>>=
module subroutine rt_data_import_values (local)
class(rt_data_t), intent(inout) :: local
end subroutine rt_data_import_values
<<RT data: procedures>>=
module subroutine rt_data_import_values (local)
class(rt_data_t), intent(inout) :: local
type(rt_data_t), pointer :: global
global => local%context
if (associated (global)) then
call local%var_list%import (global%var_list)
end if
end subroutine rt_data_import_values
@ %def rt_data_import_values
@ Unset all variable values.
<<RT data: rt data: TBP>>=
procedure :: unset_values => rt_data_unset_values
<<RT data: sub interfaces>>=
module subroutine rt_data_unset_values (global)
class(rt_data_t), intent(inout) :: global
end subroutine rt_data_unset_values
<<RT data: procedures>>=
module subroutine rt_data_unset_values (global)
class(rt_data_t), intent(inout) :: global
call global%var_list%undefine (follow_link=.false.)
end subroutine rt_data_unset_values
@ %def rt_data_unset_values
@ Set a variable. (Not a model variable, these are handled separately.) We
can assume that the variable has been initialized.
<<RT data: rt data: TBP>>=
procedure :: set_log => rt_data_set_log
procedure :: set_int => rt_data_set_int
procedure :: set_real => rt_data_set_real
procedure :: set_cmplx => rt_data_set_cmplx
procedure :: set_subevt => rt_data_set_subevt
procedure :: set_pdg_array => rt_data_set_pdg_array
procedure :: set_string => rt_data_set_string
<<RT data: sub interfaces>>=
module subroutine rt_data_set_log &
(global, name, lval, is_known, force, verbose)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
logical, intent(in) :: lval
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose
end subroutine rt_data_set_log
module subroutine rt_data_set_int &
(global, name, ival, is_known, force, verbose)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
integer, intent(in) :: ival
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose
end subroutine rt_data_set_int
module subroutine rt_data_set_real &
(global, name, rval, is_known, force, verbose, pacified)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
real(default), intent(in) :: rval
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose, pacified
end subroutine rt_data_set_real
module subroutine rt_data_set_cmplx &
(global, name, cval, is_known, force, verbose, pacified)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
complex(default), intent(in) :: cval
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose, pacified
end subroutine rt_data_set_cmplx
module subroutine rt_data_set_subevt &
(global, name, pval, is_known, force, verbose)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
type(subevt_t), intent(in) :: pval
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose
end subroutine rt_data_set_subevt
module subroutine rt_data_set_pdg_array &
(global, name, aval, is_known, force, verbose)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
type(pdg_array_t), intent(in) :: aval
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose
end subroutine rt_data_set_pdg_array
module subroutine rt_data_set_string &
(global, name, sval, is_known, force, verbose)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
type(string_t), intent(in) :: sval
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose
end subroutine rt_data_set_string
<<RT data: procedures>>=
module subroutine rt_data_set_log &
(global, name, lval, is_known, force, verbose)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
logical, intent(in) :: lval
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose
call global%var_list%set_log (name, lval, is_known, &
force=force, verbose=verbose)
end subroutine rt_data_set_log
module subroutine rt_data_set_int &
(global, name, ival, is_known, force, verbose)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
integer, intent(in) :: ival
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose
call global%var_list%set_int (name, ival, is_known, &
force=force, verbose=verbose)
end subroutine rt_data_set_int
module subroutine rt_data_set_real &
(global, name, rval, is_known, force, verbose, pacified)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
real(default), intent(in) :: rval
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose, pacified
call global%var_list%set_real (name, rval, is_known, &
force=force, verbose=verbose, pacified=pacified)
end subroutine rt_data_set_real
module subroutine rt_data_set_cmplx &
(global, name, cval, is_known, force, verbose, pacified)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
complex(default), intent(in) :: cval
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose, pacified
call global%var_list%set_cmplx (name, cval, is_known, &
force=force, verbose=verbose, pacified=pacified)
end subroutine rt_data_set_cmplx
module subroutine rt_data_set_subevt &
(global, name, pval, is_known, force, verbose)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
type(subevt_t), intent(in) :: pval
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose
call global%var_list%set_subevt (name, pval, is_known, &
force=force, verbose=verbose)
end subroutine rt_data_set_subevt
module subroutine rt_data_set_pdg_array &
(global, name, aval, is_known, force, verbose)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
type(pdg_array_t), intent(in) :: aval
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose
call global%var_list%set_pdg_array (name, aval, is_known, &
force=force, verbose=verbose)
end subroutine rt_data_set_pdg_array
module subroutine rt_data_set_string &
(global, name, sval, is_known, force, verbose)
class(rt_data_t), intent(inout) :: global
type(string_t), intent(in) :: name
type(string_t), intent(in) :: sval
logical, intent(in) :: is_known
logical, intent(in), optional :: force, verbose
call global%var_list%set_string (name, sval, is_known, &
force=force, verbose=verbose)
end subroutine rt_data_set_string
@ %def rt_data_set_log
@ %def rt_data_set_int
@ %def rt_data_set_real
@ %def rt_data_set_cmplx
@ %def rt_data_set_subevt
@ %def rt_data_set_pdg_array
@ %def rt_data_set_string
@ Return the value of a variable, assuming that the type is correct.
<<RT data: rt data: TBP>>=
procedure :: get_lval => rt_data_get_lval
procedure :: get_ival => rt_data_get_ival
procedure :: get_rval => rt_data_get_rval
procedure :: get_cval => rt_data_get_cval
procedure :: get_pval => rt_data_get_pval
procedure :: get_aval => rt_data_get_aval
procedure :: get_sval => rt_data_get_sval
<<RT data: sub interfaces>>=
module function rt_data_get_lval (global, name) result (lval)
logical :: lval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
end function rt_data_get_lval
module function rt_data_get_ival (global, name) result (ival)
integer :: ival
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
end function rt_data_get_ival
module function rt_data_get_rval (global, name) result (rval)
real(default) :: rval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
end function rt_data_get_rval
module function rt_data_get_cval (global, name) result (cval)
complex(default) :: cval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
end function rt_data_get_cval
module function rt_data_get_aval (global, name) result (aval)
type(pdg_array_t) :: aval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
end function rt_data_get_aval
module function rt_data_get_pval (global, name) result (pval)
type(subevt_t) :: pval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
end function rt_data_get_pval
module function rt_data_get_sval (global, name) result (sval)
type(string_t) :: sval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
end function rt_data_get_sval
<<RT data: procedures>>=
module function rt_data_get_lval (global, name) result (lval)
logical :: lval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
type(var_list_t), pointer :: var_list
var_list => global%get_var_list_ptr ()
lval = var_list%get_lval (name)
end function rt_data_get_lval
module function rt_data_get_ival (global, name) result (ival)
integer :: ival
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
type(var_list_t), pointer :: var_list
var_list => global%get_var_list_ptr ()
ival = var_list%get_ival (name)
end function rt_data_get_ival
module function rt_data_get_rval (global, name) result (rval)
real(default) :: rval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
type(var_list_t), pointer :: var_list
var_list => global%get_var_list_ptr ()
rval = var_list%get_rval (name)
end function rt_data_get_rval
module function rt_data_get_cval (global, name) result (cval)
complex(default) :: cval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
type(var_list_t), pointer :: var_list
var_list => global%get_var_list_ptr ()
cval = var_list%get_cval (name)
end function rt_data_get_cval
module function rt_data_get_aval (global, name) result (aval)
type(pdg_array_t) :: aval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
type(var_list_t), pointer :: var_list
var_list => global%get_var_list_ptr ()
aval = var_list%get_aval (name)
end function rt_data_get_aval
module function rt_data_get_pval (global, name) result (pval)
type(subevt_t) :: pval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
type(var_list_t), pointer :: var_list
var_list => global%get_var_list_ptr ()
pval = var_list%get_pval (name)
end function rt_data_get_pval
module function rt_data_get_sval (global, name) result (sval)
type(string_t) :: sval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
type(var_list_t), pointer :: var_list
var_list => global%get_var_list_ptr ()
sval = var_list%get_sval (name)
end function rt_data_get_sval
@ %def rt_data_get_lval
@ %def rt_data_get_ival
@ %def rt_data_get_rval
@ %def rt_data_get_cval
@ %def rt_data_get_pval
@ %def rt_data_get_aval
@ %def rt_data_get_sval
@ Return true if the variable exists in the global list.
<<RT data: rt data: TBP>>=
procedure :: contains => rt_data_contains
<<RT data: sub interfaces>>=
module function rt_data_contains (global, name) result (lval)
logical :: lval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
end function rt_data_contains
<<RT data: procedures>>=
module function rt_data_contains (global, name) result (lval)
logical :: lval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
type(var_list_t), pointer :: var_list
var_list => global%get_var_list_ptr ()
lval = var_list%contains (name)
end function rt_data_contains
@ %def rt_data_contains
@ Return true if the value of the variable is known.
<<RT data: rt data: TBP>>=
procedure :: is_known => rt_data_is_known
<<RT data: sub interfaces>>=
module function rt_data_is_known (global, name) result (lval)
logical :: lval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
end function rt_data_is_known
<<RT data: procedures>>=
module function rt_data_is_known (global, name) result (lval)
logical :: lval
class(rt_data_t), intent(in), target :: global
type(string_t), intent(in) :: name
type(var_list_t), pointer :: var_list
var_list => global%get_var_list_ptr ()
lval = var_list%is_known (name)
end function rt_data_is_known
@ %def rt_data_is_known
@
\subsection{Further Content}
Add a library (available via a pointer of type [[prclib_entry_t]]) to
the stack and update the pointer and variable list to the current
library. The pointer association of [[prclib_entry]] will be discarded.
<<RT data: rt data: TBP>>=
procedure :: add_prclib => rt_data_add_prclib
<<RT data: sub interfaces>>=
module subroutine rt_data_add_prclib (global, prclib_entry)
class(rt_data_t), intent(inout) :: global
type(prclib_entry_t), intent(inout), pointer :: prclib_entry
end subroutine rt_data_add_prclib
<<RT data: procedures>>=
module subroutine rt_data_add_prclib (global, prclib_entry)
class(rt_data_t), intent(inout) :: global
type(prclib_entry_t), intent(inout), pointer :: prclib_entry
call global%prclib_stack%push (prclib_entry)
call global%update_prclib (global%prclib_stack%get_first_ptr ())
end subroutine rt_data_add_prclib
@ %def rt_data_add_prclib
@ Given a pointer to a process library, make this the currently active
library.
<<RT data: rt data: TBP>>=
procedure :: update_prclib => rt_data_update_prclib
<<RT data: sub interfaces>>=
module subroutine rt_data_update_prclib (global, lib)
class(rt_data_t), intent(inout) :: global
type(process_library_t), intent(in), target :: lib
end subroutine rt_data_update_prclib
<<RT data: procedures>>=
module subroutine rt_data_update_prclib (global, lib)
class(rt_data_t), intent(inout) :: global
type(process_library_t), intent(in), target :: lib
global%prclib => lib
if (global%var_list%contains (&
var_str ("$library_name"), follow_link = .false.)) then
call global%var_list%set_string (var_str ("$library_name"), &
global%prclib%get_name (), is_known=.true.)
else
call global%var_list%append_string ( &
var_str ("$library_name"), global%prclib%get_name (), &
intrinsic = .true.)
end if
end subroutine rt_data_update_prclib
@ %def rt_data_update_prclib
@
\subsection{Miscellaneous}
The helicity selection data are distributed among several parameters. Here,
we collect them in a single record.
<<RT data: rt data: TBP>>=
procedure :: get_helicity_selection => rt_data_get_helicity_selection
<<RT data: sub interfaces>>=
module function rt_data_get_helicity_selection &
(rt_data) result (helicity_selection)
class(rt_data_t), intent(in) :: rt_data
type(helicity_selection_t) :: helicity_selection
end function rt_data_get_helicity_selection
<<RT data: procedures>>=
module function rt_data_get_helicity_selection &
(rt_data) result (helicity_selection)
class(rt_data_t), intent(in) :: rt_data
type(helicity_selection_t) :: helicity_selection
associate (var_list => rt_data%var_list)
helicity_selection%active = var_list%get_lval (&
var_str ("?helicity_selection_active"))
if (helicity_selection%active) then
helicity_selection%threshold = var_list%get_rval (&
var_str ("helicity_selection_threshold"))
helicity_selection%cutoff = var_list%get_ival (&
var_str ("helicity_selection_cutoff"))
end if
end associate
end function rt_data_get_helicity_selection
@ %def rt_data_get_helicity_selection
@ Show the beam setup: beam structure and relevant global variables.
<<RT data: rt data: TBP>>=
procedure :: show_beams => rt_data_show_beams
<<RT data: sub interfaces>>=
module subroutine rt_data_show_beams (rt_data, unit)
class(rt_data_t), intent(in) :: rt_data
integer, intent(in), optional :: unit
end subroutine rt_data_show_beams
<<RT data: procedures>>=
module subroutine rt_data_show_beams (rt_data, unit)
class(rt_data_t), intent(in) :: rt_data
integer, intent(in), optional :: unit
type(string_t) :: s
integer :: u
u = given_output_unit (unit)
associate (beams => rt_data%beam_structure, var_list => rt_data%var_list)
call beams%write (u)
if (.not. beams%asymmetric () .and. beams%get_n_beam () == 2) then
write (u, "(2x,A," // FMT_19 // ",1x,'GeV')") "sqrts =", &
var_list%get_rval (var_str ("sqrts"))
end if
if (beams%contains ("pdf_builtin")) then
s = var_list%get_sval (var_str ("$pdf_builtin_set"))
if (s /= "") then
write (u, "(2x,A,1x,3A)") "PDF set =", '"', char (s), '"'
else
write (u, "(2x,A,1x,A)") "PDF set =", "[undefined]"
end if
end if
if (beams%contains ("lhapdf")) then
s = var_list%get_sval (var_str ("$lhapdf_dir"))
if (s /= "") then
write (u, "(2x,A,1x,3A)") "LHAPDF dir =", '"', char (s), '"'
end if
s = var_list%get_sval (var_str ("$lhapdf_file"))
if (s /= "") then
write (u, "(2x,A,1x,3A)") "LHAPDF file =", '"', char (s), '"'
write (u, "(2x,A,1x,I0)") "LHAPDF member =", &
var_list%get_ival (var_str ("lhapdf_member"))
else
write (u, "(2x,A,1x,A)") "LHAPDF file =", "[undefined]"
end if
end if
if (beams%contains ("lhapdf_photon")) then
s = var_list%get_sval (var_str ("$lhapdf_dir"))
if (s /= "") then
write (u, "(2x,A,1x,3A)") "LHAPDF dir =", '"', char (s), '"'
end if
s = var_list%get_sval (var_str ("$lhapdf_photon_file"))
if (s /= "") then
write (u, "(2x,A,1x,3A)") "LHAPDF file =", '"', char (s), '"'
write (u, "(2x,A,1x,I0)") "LHAPDF member =", &
var_list%get_ival (var_str ("lhapdf_member"))
write (u, "(2x,A,1x,I0)") "LHAPDF scheme =", &
var_list%get_ival (&
var_str ("lhapdf_photon_scheme"))
else
write (u, "(2x,A,1x,A)") "LHAPDF file =", "[undefined]"
end if
end if
if (beams%contains ("isr")) then
write (u, "(2x,A," // FMT_19 // ")") "ISR alpha =", &
var_list%get_rval (var_str ("isr_alpha"))
write (u, "(2x,A," // FMT_19 // ")") "ISR Q max =", &
var_list%get_rval (var_str ("isr_q_max"))
write (u, "(2x,A," // FMT_19 // ")") "ISR mass =", &
var_list%get_rval (var_str ("isr_mass"))
write (u, "(2x,A,1x,I0)") "ISR order =", &
var_list%get_ival (var_str ("isr_order"))
write (u, "(2x,A,1x,L1)") "ISR recoil =", &
var_list%get_lval (var_str ("?isr_recoil"))
write (u, "(2x,A,1x,L1)") "ISR energy cons. =", &
var_list%get_lval (var_str ("?isr_keep_energy"))
end if
if (beams%contains ("epa")) then
write (u, "(2x,A," // FMT_19 // ")") "EPA alpha =", &
var_list%get_rval (var_str ("epa_alpha"))
write (u, "(2x,A," // FMT_19 // ")") "EPA x min =", &
var_list%get_rval (var_str ("epa_x_min"))
write (u, "(2x,A," // FMT_19 // ")") "EPA Q min =", &
var_list%get_rval (var_str ("epa_q_min"))
write (u, "(2x,A," // FMT_19 // ")") "EPA Q max =", &
var_list%get_rval (var_str ("epa_q_max"))
write (u, "(2x,A," // FMT_19 // ")") "EPA mass =", &
var_list%get_rval (var_str ("epa_mass"))
write (u, "(2x,A,1x,L1)") "EPA recoil =", &
var_list%get_lval (var_str ("?epa_recoil"))
write (u, "(2x,A,1x,L1)") "EPA energy cons. =", &
var_list%get_lval (var_str ("?epa_keep_energy"))
end if
if (beams%contains ("ewa")) then
write (u, "(2x,A," // FMT_19 // ")") "EWA x min =", &
var_list%get_rval (var_str ("ewa_x_min"))
write (u, "(2x,A," // FMT_19 // ")") "EWA Pt max =", &
var_list%get_rval (var_str ("ewa_pt_max"))
write (u, "(2x,A," // FMT_19 // ")") "EWA mass =", &
var_list%get_rval (var_str ("ewa_mass"))
write (u, "(2x,A,1x,L1)") "EWA recoil =", &
var_list%get_lval (var_str ("?ewa_recoil"))
write (u, "(2x,A,1x,L1)") "EWA energy cons. =", &
var_list%get_lval (var_str ("ewa_keep_energy"))
end if
if (beams%contains ("circe1")) then
write (u, "(2x,A,1x,I0)") "CIRCE1 version =", &
var_list%get_ival (var_str ("circe1_ver"))
write (u, "(2x,A,1x,I0)") "CIRCE1 revision =", &
var_list%get_ival (var_str ("circe1_rev"))
s = var_list%get_sval (var_str ("$circe1_acc"))
write (u, "(2x,A,1x,A)") "CIRCE1 acceler. =", char (s)
write (u, "(2x,A,1x,I0)") "CIRCE1 chattin. =", &
var_list%get_ival (var_str ("circe1_chat"))
write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 sqrts =", &
var_list%get_rval (var_str ("circe1_sqrts"))
write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 epsil. =", &
var_list%get_rval (var_str ("circe1_eps"))
write (u, "(2x,A,1x,L1)") "CIRCE1 phot. 1 =", &
var_list%get_lval (var_str ("?circe1_photon1"))
write (u, "(2x,A,1x,L1)") "CIRCE1 phot. 2 =", &
var_list%get_lval (var_str ("?circe1_photon2"))
write (u, "(2x,A,1x,L1)") "CIRCE1 generat. =", &
var_list%get_lval (var_str ("?circe1_generate"))
write (u, "(2x,A,1x,L1)") "CIRCE1 mapping =", &
var_list%get_lval (var_str ("?circe1_map"))
write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 map. slope =", &
var_list%get_rval (var_str ("circe1_mapping_slope"))
write (u, "(2x,A,1x,L1)") "CIRCE recoil photon =", &
var_list%get_lval (var_str ("?circe1_with_radiation"))
end if
if (beams%contains ("circe2")) then
s = var_list%get_sval (var_str ("$circe2_design"))
write (u, "(2x,A,1x,A)") "CIRCE2 design =", char (s)
s = var_list%get_sval (var_str ("$circe2_file"))
write (u, "(2x,A,1x,A)") "CIRCE2 file =", char (s)
write (u, "(2x,A,1x,L1)") "CIRCE2 polarized =", &
var_list%get_lval (var_str ("?circe2_polarized"))
end if
if (beams%contains ("gaussian")) then
write (u, "(2x,A,1x," // FMT_12 // ")") "Gaussian spread 1 =", &
var_list%get_rval (var_str ("gaussian_spread1"))
write (u, "(2x,A,1x," // FMT_12 // ")") "Gaussian spread 2 =", &
var_list%get_rval (var_str ("gaussian_spread2"))
end if
if (beams%contains ("beam_events")) then
s = var_list%get_sval (var_str ("$beam_events_file"))
write (u, "(2x,A,1x,A)") "Beam events file =", char (s)
write (u, "(2x,A,1x,L1)") "Beam events EOF warn =", &
var_list%get_lval (var_str ("?beam_events_warn_eof"))
end if
end associate
end subroutine rt_data_show_beams
@ %def rt_data_show_beams
@ Return the collision energy as determined by the current beam
settings. Without beam setup, this is the [[sqrts]] variable.
If the value is meaningless for a setup, the function returns zero.
<<RT data: rt data: TBP>>=
procedure :: get_sqrts => rt_data_get_sqrts
<<RT data: sub interfaces>>=
module function rt_data_get_sqrts (rt_data) result (sqrts)
class(rt_data_t), intent(in) :: rt_data
real(default) :: sqrts
end function rt_data_get_sqrts
<<RT data: procedures>>=
module function rt_data_get_sqrts (rt_data) result (sqrts)
class(rt_data_t), intent(in) :: rt_data
real(default) :: sqrts
sqrts = rt_data%var_list%get_rval (var_str ("sqrts"))
end function rt_data_get_sqrts
@ %def rt_data_get_sqrts
@ For testing purposes, the [[rt_data_t]] contents can be pacified to
suppress numerical fluctuations in (constant) test matrix elements.
<<RT data: rt data: TBP>>=
procedure :: pacify => rt_data_pacify
<<RT data: sub interfaces>>=
module subroutine rt_data_pacify (rt_data, efficiency_reset, error_reset)
class(rt_data_t), intent(inout) :: rt_data
logical, intent(in), optional :: efficiency_reset, error_reset
end subroutine rt_data_pacify
<<RT data: procedures>>=
module subroutine rt_data_pacify (rt_data, efficiency_reset, error_reset)
class(rt_data_t), intent(inout) :: rt_data
logical, intent(in), optional :: efficiency_reset, error_reset
type(process_entry_t), pointer :: process
process => rt_data%process_stack%first
do while (associated (process))
call process%pacify (efficiency_reset, error_reset)
process => process%next
end do
end subroutine rt_data_pacify
@ %def rt_data_pacify
@
<<RT data: rt data: TBP>>=
procedure :: set_event_callback => rt_data_set_event_callback
<<RT data: sub interfaces>>=
module subroutine rt_data_set_event_callback (global, callback)
class(rt_data_t), intent(inout) :: global
class(event_callback_t), intent(in) :: callback
end subroutine rt_data_set_event_callback
<<RT data: procedures>>=
module subroutine rt_data_set_event_callback (global, callback)
class(rt_data_t), intent(inout) :: global
class(event_callback_t), intent(in) :: callback
if (allocated (global%event_callback)) deallocate (global%event_callback)
allocate (global%event_callback, source = callback)
end subroutine rt_data_set_event_callback
@ %def rt_data_set_event_callback
@
<<RT data: rt data: TBP>>=
procedure :: has_event_callback => rt_data_has_event_callback
procedure :: get_event_callback => rt_data_get_event_callback
<<RT data: sub interfaces>>=
module function rt_data_has_event_callback (global) result (flag)
class(rt_data_t), intent(in) :: global
logical :: flag
end function rt_data_has_event_callback
module function rt_data_get_event_callback (global) result (callback)
class(rt_data_t), intent(in) :: global
class(event_callback_t), allocatable :: callback
end function rt_data_get_event_callback
<<RT data: procedures>>=
module function rt_data_has_event_callback (global) result (flag)
class(rt_data_t), intent(in) :: global
logical :: flag
flag = allocated (global%event_callback)
end function rt_data_has_event_callback
module function rt_data_get_event_callback (global) result (callback)
class(rt_data_t), intent(in) :: global
class(event_callback_t), allocatable :: callback
if (allocated (global%event_callback)) then
allocate (callback, source = global%event_callback)
end if
end function rt_data_get_event_callback
@ %def rt_data_has_event_callback
@ %def rt_data_get_event_callback
@ Force system-dependent objects to well-defined values. Some of the
variables are locked and therefore must be addressed directly.
This is, of course, only required for testing purposes. In principle,
the [[real_specimen]] variables could be set to their values in
[[rt_data_t]], but this depends on the precision again, so we set
them to some dummy values.
<<RT data: public>>=
public :: fix_system_dependencies
<<RT data: sub interfaces>>=
module subroutine fix_system_dependencies (global)
class(rt_data_t), intent(inout), target :: global
end subroutine fix_system_dependencies
<<RT data: procedures>>=
module subroutine fix_system_dependencies (global)
class(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
var_list => global%get_var_list_ptr ()
call var_list%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true., force=.true.)
call var_list%set_log (var_str ("?openmp_is_active"), &
.false., is_known = .true., force=.true.)
call var_list%set_int (var_str ("openmp_num_threads_default"), &
1, is_known = .true., force=.true.)
call var_list%set_int (var_str ("openmp_num_threads"), &
1, is_known = .true., force=.true.)
call var_list%set_int (var_str ("real_range"), &
307, is_known = .true., force=.true.)
call var_list%set_int (var_str ("real_precision"), &
15, is_known = .true., force=.true.)
call var_list%set_real (var_str ("real_epsilon"), &
1.e-16_default, is_known = .true., force=.true.)
call var_list%set_real (var_str ("real_tiny"), &
1.e-300_default, is_known = .true., force=.true.)
global%os_data%fc = "Fortran-compiler"
global%os_data%fcflags = "Fortran-flags"
global%os_data%fclibs = "Fortran-libs"
end subroutine fix_system_dependencies
@ %def fix_system_dependencies
@
<<RT data: public>>=
public :: show_description_of_string
<<RT data: sub interfaces>>=
module subroutine show_description_of_string (string)
type(string_t), intent(in) :: string
end subroutine show_description_of_string
<<RT data: procedures>>=
module subroutine show_description_of_string (string)
type(string_t), intent(in) :: string
type(rt_data_t), target :: global
call global%global_init ()
call global%show_description_of_string (string, ascii_output=.true.)
end subroutine show_description_of_string
@ %def show_description_of_string
@
<<RT data: public>>=
public :: show_tex_descriptions
<<RT data: sub interfaces>>=
module subroutine show_tex_descriptions ()
end subroutine show_tex_descriptions
<<RT data: procedures>>=
module subroutine show_tex_descriptions ()
type(rt_data_t), target :: global
call global%global_init ()
call fix_system_dependencies (global)
call global%set_int (var_str ("seed"), 0, is_known=.true.)
call global%var_list%sort ()
call global%write_var_descriptions ()
end subroutine show_tex_descriptions
@ %def show_tex_descriptions
@
\subsection{Unit Tests}
Test module, followed by the corresponding implementation module.
<<[[rt_data_ut.f90]]>>=
<<File header>>
module rt_data_ut
use unit_tests
use rt_data_uti
<<Standard module head>>
<<RT data: public test>>
contains
<<RT data: test driver>>
end module rt_data_ut
@ %def rt_data_ut
@
<<[[rt_data_uti.f90]]>>=
<<File header>>
module rt_data_uti
<<Use kinds>>
<<Use strings>>
use format_defs, only: FMT_19
use ifiles
use lexers
use parser
use flavors
use variables, only: var_list_t
use eval_trees
use models
use prclib_stacks
use rt_data
<<Standard module head>>
<<RT data: test declarations>>
contains
<<RT data: test auxiliary>>
<<RT data: tests>>
end module rt_data_uti
@ %def rt_data_ut
@ API: driver for the unit tests below.
<<RT data: public test>>=
public :: rt_data_test
<<RT data: test driver>>=
subroutine rt_data_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<RT data: execute tests>>
end subroutine rt_data_test
@ %def rt_data_test
@
\subsubsection{Initial content}
@
Display the RT data in the state just after (global) initialization.
<<RT data: execute tests>>=
call test (rt_data_1, "rt_data_1", &
"initialize", &
u, results)
<<RT data: test declarations>>=
public :: rt_data_1
<<RT data: tests>>=
subroutine rt_data_1 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
write (u, "(A)") "* Test output: rt_data_1"
write (u, "(A)") "* Purpose: initialize global runtime data"
write (u, "(A)")
call global%global_init (logfile = var_str ("rt_data.log"))
call fix_system_dependencies (global)
call global%set_int (var_str ("seed"), 0, is_known=.true.)
call global%it_list%init ([2, 3], [5000, 20000])
call global%write (u)
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: rt_data_1"
end subroutine rt_data_1
@ %def rt_data_1
@
\subsubsection{Fill values}
Fill in empty slots in the runtime data block.
<<RT data: execute tests>>=
call test (rt_data_2, "rt_data_2", &
"fill", &
u, results)
<<RT data: test declarations>>=
public :: rt_data_2
<<RT data: tests>>=
subroutine rt_data_2 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
type(flavor_t), dimension(2) :: flv
type(string_t) :: cut_expr_text
type(ifile_t) :: ifile
type(stream_t) :: stream
type(parse_tree_t) :: parse_tree
write (u, "(A)") "* Test output: rt_data_2"
write (u, "(A)") "* Purpose: initialize global runtime data &
&and fill contents"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call fix_system_dependencies (global)
call global%select_model (var_str ("Test"))
call global%set_real (var_str ("sqrts"), &
1000._default, is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known=.true.)
call flv%init ([25,25], global%model)
call global%set_string (var_str ("$run_id"), &
var_str ("run1"), is_known = .true.)
call global%set_real (var_str ("luminosity"), &
33._default, is_known = .true.)
call syntax_pexpr_init ()
cut_expr_text = "all Pt > 100 [s]"
call ifile_append (ifile, cut_expr_text)
call stream_init (stream, ifile)
call parse_tree_init_lexpr (parse_tree, stream, .true.)
global%pn%cuts_lexpr => parse_tree%get_root_ptr ()
allocate (global%sample_fmt (2))
global%sample_fmt(1) = "foo_fmt"
global%sample_fmt(2) = "bar_fmt"
call global%write (u)
call parse_tree_final (parse_tree)
call stream_final (stream)
call ifile_final (ifile)
call syntax_pexpr_final ()
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: rt_data_2"
end subroutine rt_data_2
@ %def rt_data_2
@
\subsubsection{Save and restore}
Set up a local runtime data block, change some contents, restore the
global block.
<<RT data: execute tests>>=
call test (rt_data_3, "rt_data_3", &
"save/restore", &
u, results)
<<RT data: test declarations>>=
public :: rt_data_3
<<RT data: tests>>=
subroutine rt_data_3 (u)
use event_base, only: event_callback_nop_t
integer, intent(in) :: u
type(rt_data_t), target :: global, local
type(flavor_t), dimension(2) :: flv
type(string_t) :: cut_expr_text
type(ifile_t) :: ifile
type(stream_t) :: stream
type(parse_tree_t) :: parse_tree
type(prclib_entry_t), pointer :: lib
type(event_callback_nop_t) :: event_callback_nop
write (u, "(A)") "* Test output: rt_data_3"
write (u, "(A)") "* Purpose: initialize global runtime data &
&and fill contents;"
write (u, "(A)") "* copy to local block and back"
write (u, "(A)")
write (u, "(A)") "* Init global data"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call fix_system_dependencies (global)
call global%set_int (var_str ("seed"), &
0, is_known=.true.)
call global%select_model (var_str ("Test"))
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call flv%init ([25,25], global%model)
call global%beam_structure%init_sf (flv%get_name (), [1])
call global%beam_structure%set_sf (1, 1, var_str ("pdf_builtin"))
call global%set_string (var_str ("$run_id"), &
var_str ("run1"), is_known = .true.)
call global%set_real (var_str ("luminosity"), &
33._default, is_known = .true.)
call syntax_pexpr_init ()
cut_expr_text = "all Pt > 100 [s]"
call ifile_append (ifile, cut_expr_text)
call stream_init (stream, ifile)
call parse_tree_init_lexpr (parse_tree, stream, .true.)
global%pn%cuts_lexpr => parse_tree%get_root_ptr ()
allocate (global%sample_fmt (2))
global%sample_fmt(1) = "foo_fmt"
global%sample_fmt(2) = "bar_fmt"
allocate (lib)
call lib%init (var_str ("library_1"))
call global%add_prclib (lib)
write (u, "(A)") "* Init and modify local data"
write (u, "(A)")
call local%local_init (global)
call local%append_string (var_str ("$integration_method"), intrinsic=.true.)
call local%append_string (var_str ("$phs_method"), intrinsic=.true.)
call local%activate ()
write (u, "(1x,A,L1)") "model associated = ", associated (local%model)
write (u, "(1x,A,L1)") "library associated = ", associated (local%prclib)
write (u, *)
call local%model_set_real (var_str ("ms"), 150._default)
call local%set_string (var_str ("$integration_method"), &
var_str ("midpoint"), is_known = .true.)
call local%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
local%os_data%fc = "Local compiler"
allocate (lib)
call lib%init (var_str ("library_2"))
call local%add_prclib (lib)
call local%set_event_callback (event_callback_nop)
call local%write (u)
write (u, "(A)")
write (u, "(A)") "* Restore global data"
write (u, "(A)")
call local%deactivate (global)
write (u, "(1x,A,L1)") "model associated = ", associated (global%model)
write (u, "(1x,A,L1)") "library associated = ", associated (global%prclib)
write (u, *)
call global%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call parse_tree_final (parse_tree)
call stream_final (stream)
call ifile_final (ifile)
call syntax_pexpr_final ()
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: rt_data_3"
end subroutine rt_data_3
@ %def rt_data_3
@
\subsubsection{Show variables}
Display selected variables in the global record.
<<RT data: execute tests>>=
call test (rt_data_4, "rt_data_4", &
"show variables", &
u, results)
<<RT data: test declarations>>=
public :: rt_data_4
<<RT data: tests>>=
subroutine rt_data_4 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
type(string_t), dimension(0) :: empty_string_array
write (u, "(A)") "* Test output: rt_data_4"
write (u, "(A)") "* Purpose: display selected variables"
write (u, "(A)")
call global%global_init ()
write (u, "(A)") "* No variables:"
write (u, "(A)")
call global%write_vars (u, empty_string_array)
write (u, "(A)") "* Two variables:"
write (u, "(A)")
call global%write_vars (u, &
[var_str ("?unweighted"), var_str ("$phs_method")])
write (u, "(A)")
write (u, "(A)") "* Display whole record with selected variables"
write (u, "(A)")
call global%write (u, &
vars = [var_str ("?unweighted"), var_str ("$phs_method")])
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: rt_data_4"
end subroutine rt_data_4
@ %def rt_data_4
@
\subsubsection{Show parts}
Display only selected parts in the state just after (global) initialization.
<<RT data: execute tests>>=
call test (rt_data_5, "rt_data_5", &
"show parts", &
u, results)
<<RT data: test declarations>>=
public :: rt_data_5
<<RT data: tests>>=
subroutine rt_data_5 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
write (u, "(A)") "* Test output: rt_data_5"
write (u, "(A)") "* Purpose: display parts of rt data"
write (u, "(A)")
call global%global_init ()
call global%write_libraries (u)
write (u, "(A)")
call global%write_beams (u)
write (u, "(A)")
call global%write_process_stack (u)
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: rt_data_5"
end subroutine rt_data_5
@ %def rt_data_5
@
\subsubsection{Local Model}
Locally modify a model and restore the global one. We need an auxiliary
function to determine the status of a model particle:
<<RT data: test auxiliary>>=
function is_stable (pdg, global) result (flag)
integer, intent(in) :: pdg
type(rt_data_t), intent(in) :: global
logical :: flag
type(flavor_t) :: flv
call flv%init (pdg, global%model)
flag = flv%is_stable ()
end function is_stable
function is_polarized (pdg, global) result (flag)
integer, intent(in) :: pdg
type(rt_data_t), intent(in) :: global
logical :: flag
type(flavor_t) :: flv
call flv%init (pdg, global%model)
flag = flv%is_polarized ()
end function is_polarized
@ %def is_stable is_polarized
<<RT data: execute tests>>=
call test (rt_data_6, "rt_data_6", &
"local model", &
u, results)
<<RT data: test declarations>>=
public :: rt_data_6
<<RT data: tests>>=
subroutine rt_data_6 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global, local
type(var_list_t), pointer :: model_vars
type(string_t) :: var_name
write (u, "(A)") "* Test output: rt_data_6"
write (u, "(A)") "* Purpose: apply and keep local modifications to model"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%select_model (var_str ("Test"))
write (u, "(A)") "* Original model"
write (u, "(A)")
call global%write_model_list (u)
write (u, *)
write (u, "(A,L1)") "s is stable = ", is_stable (25, global)
write (u, "(A,L1)") "f is polarized = ", is_polarized (6, global)
write (u, *)
var_name = "ff"
write (u, "(A)", advance="no") "Global model variable: "
model_vars => global%model%get_var_list_ptr ()
call model_vars%write_var (var_name, u)
write (u, "(A)")
write (u, "(A)") "* Apply local modifications: unstable"
write (u, "(A)")
call local%local_init (global)
call local%activate ()
call local%model_set_real (var_name, 0.4_default)
call local%modify_particle (25, stable = .false., decay = [var_str ("d1")])
call local%modify_particle (6, stable = .false., &
decay = [var_str ("f1")], isotropic_decay = .true.)
call local%modify_particle (-6, stable = .false., &
decay = [var_str ("f2"), var_str ("f3")], diagonal_decay = .true.)
call local%model%write (u)
write (u, "(A)")
write (u, "(A)") "* Further modifications"
write (u, "(A)")
call local%modify_particle (6, stable = .false., &
decay = [var_str ("f1")], &
diagonal_decay = .true., isotropic_decay = .false.)
call local%modify_particle (-6, stable = .false., &
decay = [var_str ("f2"), var_str ("f3")], &
diagonal_decay = .false., isotropic_decay = .true.)
call local%model%write (u)
write (u, "(A)")
write (u, "(A)") "* Further modifications: f stable but polarized"
write (u, "(A)")
call local%modify_particle (6, stable = .true., polarized = .true.)
call local%modify_particle (-6, stable = .true.)
call local%model%write (u)
write (u, "(A)")
write (u, "(A)") "* Global model"
write (u, "(A)")
call global%model%write (u)
write (u, *)
write (u, "(A,L1)") "s is stable = ", is_stable (25, global)
write (u, "(A,L1)") "f is polarized = ", is_polarized (6, global)
write (u, "(A)")
write (u, "(A)") "* Local model"
write (u, "(A)")
call local%model%write (u)
write (u, *)
write (u, "(A,L1)") "s is stable = ", is_stable (25, local)
write (u, "(A,L1)") "f is polarized = ", is_polarized (6, local)
write (u, *)
write (u, "(A)", advance="no") "Global model variable: "
model_vars => global%model%get_var_list_ptr ()
call model_vars%write_var (var_name, u)
write (u, "(A)", advance="no") "Local model variable: "
associate (model_var_list_ptr => local%model%get_var_list_ptr())
call model_var_list_ptr%write_var (var_name, u)
end associate
write (u, "(A)")
write (u, "(A)") "* Restore global"
call local%deactivate (global, keep_local = .true.)
write (u, "(A)")
write (u, "(A)") "* Global model"
write (u, "(A)")
call global%model%write (u)
write (u, *)
write (u, "(A,L1)") "s is stable = ", is_stable (25, global)
write (u, "(A,L1)") "f is polarized = ", is_polarized (6, global)
write (u, "(A)")
write (u, "(A)") "* Local model"
write (u, "(A)")
call local%model%write (u)
write (u, *)
write (u, "(A,L1)") "s is stable = ", is_stable (25, local)
write (u, "(A,L1)") "f is polarized = ", is_polarized (6, local)
write (u, *)
write (u, "(A)", advance="no") "Global model variable: "
model_vars => global%model%get_var_list_ptr ()
call model_vars%write_var (var_name, u)
write (u, "(A)", advance="no") "Local model variable: "
associate (model_var_list_ptr => local%model%get_var_list_ptr())
call model_var_list_ptr%write_var (var_name, u)
end associate
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call local%model%final ()
deallocate (local%model)
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: rt_data_6"
end subroutine rt_data_6
@ %def rt_data_6
@
\subsubsection{Result variables}
Initialize result variables and check that they are accessible via the
global variable list.
<<RT data: execute tests>>=
call test (rt_data_7, "rt_data_7", &
"result variables", &
u, results)
<<RT data: test declarations>>=
public :: rt_data_7
<<RT data: tests>>=
subroutine rt_data_7 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
write (u, "(A)") "* Test output: rt_data_7"
write (u, "(A)") "* Purpose: set and access result variables"
write (u, "(A)")
write (u, "(A)") "* Initialize process variables"
write (u, "(A)")
call global%global_init ()
call global%process_stack%init_result_vars (var_str ("testproc"))
call global%var_list%write_var (&
var_str ("integral(testproc)"), u, defined=.true.)
call global%var_list%write_var (&
var_str ("error(testproc)"), u, defined=.true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: rt_data_7"
end subroutine rt_data_7
@ %def rt_data_7
@
\subsubsection{Beam energy}
If beam parameters are set, the variable [[sqrts]] is not necessarily
the collision energy. The method [[get_sqrts]] fetches the correct value.
<<RT data: execute tests>>=
call test (rt_data_8, "rt_data_8", &
"beam energy", &
u, results)
<<RT data: test declarations>>=
public :: rt_data_8
<<RT data: tests>>=
subroutine rt_data_8 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
write (u, "(A)") "* Test output: rt_data_8"
write (u, "(A)") "* Purpose: get correct collision energy"
write (u, "(A)")
write (u, "(A)") "* Initialize"
write (u, "(A)")
call global%global_init ()
write (u, "(A)") "* Set sqrts"
write (u, "(A)")
call global%set_real (var_str ("sqrts"), &
1000._default, is_known = .true.)
write (u, "(1x,A," // FMT_19 // ")") "sqrts =", global%get_sqrts ()
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: rt_data_8"
end subroutine rt_data_8
@ %def rt_data_8
@
\subsubsection{Local variable modifications}
<<RT data: execute tests>>=
call test (rt_data_9, "rt_data_9", &
"local variables", &
u, results)
<<RT data: test declarations>>=
public :: rt_data_9
<<RT data: tests>>=
subroutine rt_data_9 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global, local
type(var_list_t), pointer :: var_list
write (u, "(A)") "* Test output: rt_data_9"
write (u, "(A)") "* Purpose: handle local variables"
write (u, "(A)")
call syntax_model_file_init ()
write (u, "(A)") "* Initialize global record and set some variables"
write (u, "(A)")
call global%global_init ()
call global%select_model (var_str ("Test"))
call global%set_real (var_str ("sqrts"), 17._default, is_known = .true.)
call global%set_real (var_str ("luminosity"), 2._default, is_known = .true.)
call global%model_set_real (var_str ("ff"), 0.5_default)
call global%model_set_real (var_str ("gy"), 1.2_default)
var_list => global%get_var_list_ptr ()
call var_list%write_var (var_str ("sqrts"), u, defined=.true.)
call var_list%write_var (var_str ("luminosity"), u, defined=.true.)
call var_list%write_var (var_str ("ff"), u, defined=.true.)
call var_list%write_var (var_str ("gy"), u, defined=.true.)
call var_list%write_var (var_str ("mf"), u, defined=.true.)
call var_list%write_var (var_str ("x"), u, defined=.true.)
write (u, "(A)")
write (u, "(1x,A,1x,F5.2)") "sqrts = ", &
global%get_rval (var_str ("sqrts"))
write (u, "(1x,A,1x,F5.2)") "luminosity = ", &
global%get_rval (var_str ("luminosity"))
write (u, "(1x,A,1x,F5.2)") "ff = ", &
global%get_rval (var_str ("ff"))
write (u, "(1x,A,1x,F5.2)") "gy = ", &
global%get_rval (var_str ("gy"))
write (u, "(1x,A,1x,F5.2)") "mf = ", &
global%get_rval (var_str ("mf"))
write (u, "(1x,A,1x,F5.2)") "x = ", &
global%get_rval (var_str ("x"))
write (u, "(A)")
write (u, "(A)") "* Create local record with local variables"
write (u, "(A)")
call local%local_init (global)
call local%append_real (var_str ("luminosity"), intrinsic = .true.)
call local%append_real (var_str ("x"), user = .true.)
call local%activate ()
var_list => local%get_var_list_ptr ()
call var_list%write_var (var_str ("sqrts"), u)
call var_list%write_var (var_str ("luminosity"), u)
call var_list%write_var (var_str ("ff"), u)
call var_list%write_var (var_str ("gy"), u)
call var_list%write_var (var_str ("mf"), u)
call var_list%write_var (var_str ("x"), u, defined=.true.)
write (u, "(A)")
write (u, "(1x,A,1x,F5.2)") "sqrts = ", &
local%get_rval (var_str ("sqrts"))
write (u, "(1x,A,1x,F5.2)") "luminosity = ", &
local%get_rval (var_str ("luminosity"))
write (u, "(1x,A,1x,F5.2)") "ff = ", &
local%get_rval (var_str ("ff"))
write (u, "(1x,A,1x,F5.2)") "gy = ", &
local%get_rval (var_str ("gy"))
write (u, "(1x,A,1x,F5.2)") "mf = ", &
local%get_rval (var_str ("mf"))
write (u, "(1x,A,1x,F5.2)") "x = ", &
local%get_rval (var_str ("x"))
write (u, "(A)")
write (u, "(A)") "* Modify some local variables"
write (u, "(A)")
call local%set_real (var_str ("luminosity"), 42._default, is_known=.true.)
call local%set_real (var_str ("x"), 6.66_default, is_known=.true.)
call local%model_set_real (var_str ("ff"), 0.7_default)
var_list => local%get_var_list_ptr ()
call var_list%write_var (var_str ("sqrts"), u)
call var_list%write_var (var_str ("luminosity"), u)
call var_list%write_var (var_str ("ff"), u)
call var_list%write_var (var_str ("gy"), u)
call var_list%write_var (var_str ("mf"), u)
call var_list%write_var (var_str ("x"), u, defined=.true.)
write (u, "(A)")
write (u, "(1x,A,1x,F5.2)") "sqrts = ", &
local%get_rval (var_str ("sqrts"))
write (u, "(1x,A,1x,F5.2)") "luminosity = ", &
local%get_rval (var_str ("luminosity"))
write (u, "(1x,A,1x,F5.2)") "ff = ", &
local%get_rval (var_str ("ff"))
write (u, "(1x,A,1x,F5.2)") "gy = ", &
local%get_rval (var_str ("gy"))
write (u, "(1x,A,1x,F5.2)") "mf = ", &
local%get_rval (var_str ("mf"))
write (u, "(1x,A,1x,F5.2)") "x = ", &
local%get_rval (var_str ("x"))
write (u, "(A)")
write (u, "(A)") "* Restore globals"
write (u, "(A)")
call local%deactivate (global)
var_list => global%get_var_list_ptr ()
call var_list%write_var (var_str ("sqrts"), u)
call var_list%write_var (var_str ("luminosity"), u)
call var_list%write_var (var_str ("ff"), u)
call var_list%write_var (var_str ("gy"), u)
call var_list%write_var (var_str ("mf"), u)
call var_list%write_var (var_str ("x"), u, defined=.true.)
write (u, "(A)")
write (u, "(1x,A,1x,F5.2)") "sqrts = ", &
global%get_rval (var_str ("sqrts"))
write (u, "(1x,A,1x,F5.2)") "luminosity = ", &
global%get_rval (var_str ("luminosity"))
write (u, "(1x,A,1x,F5.2)") "ff = ", &
global%get_rval (var_str ("ff"))
write (u, "(1x,A,1x,F5.2)") "gy = ", &
global%get_rval (var_str ("gy"))
write (u, "(1x,A,1x,F5.2)") "mf = ", &
global%get_rval (var_str ("mf"))
write (u, "(1x,A,1x,F5.2)") "x = ", &
global%get_rval (var_str ("x"))
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call local%local_final ()
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: rt_data_9"
end subroutine rt_data_9
@ %def rt_data_9
@
\subsubsection{Descriptions}
<<RT data: execute tests>>=
call test(rt_data_10, "rt_data_10", &
"descriptions", u, results)
<<RT data: test declarations>>=
public :: rt_data_10
<<RT data: tests>>=
subroutine rt_data_10 (u)
integer, intent(in) :: u
type(rt_data_t) :: global
! type(var_list_t) :: var_list
write (u, "(A)") "* Test output: rt_data_10"
write (u, "(A)") "* Purpose: display descriptions"
write (u, "(A)")
call global%var_list%append_real (var_str ("sqrts"), &
intrinsic=.true., &
description=var_str ('Real variable in order to set the center-of-mass ' // &
'energy for the collisions.'))
call global%var_list%append_real (var_str ("luminosity"), 0._default, &
intrinsic=.true., &
description=var_str ('This specifier \ttt{luminosity = {\em ' // &
'<num>}} sets the integrated luminosity (in inverse femtobarns, ' // &
'fb${}^{-1}$) for the event generation of the processes in the ' // &
'\sindarin\ input files.'))
call global%var_list%append_int (var_str ("seed"), 1234, &
intrinsic=.true., &
description=var_str ('Integer variable \ttt{seed = {\em <num>}} ' // &
'that allows to set a specific random seed \ttt{num}.'))
call global%var_list%append_string (var_str ("$method"), var_str ("omega"), &
intrinsic=.true., &
description=var_str ('This string variable specifies the method ' // &
'for the matrix elements to be used in the evaluation.'))
call global%var_list%append_log (var_str ("?read_color_factors"), .true., &
intrinsic=.true., &
description=var_str ('This flag decides whether to read QCD ' // &
'color factors from the matrix element provided by each method, ' // &
'or to try and calculate the color factors in \whizard\ internally.'))
call global%var_list%sort ()
call global%write_var_descriptions (u)
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: rt_data_10"
end subroutine rt_data_10
@ %def rt_data_10
@
\subsubsection{Export objects}
Export objects are variables or other data that should be copied or otherwise
applied to corresponding objects in the outer scope.
We test appending and retrieval for the export list.
<<RT data: execute tests>>=
call test(rt_data_11, "rt_data_11", &
"export objects", u, results)
<<RT data: test declarations>>=
public :: rt_data_11
<<RT data: tests>>=
subroutine rt_data_11 (u)
integer, intent(in) :: u
type(rt_data_t) :: global
type(string_t), dimension(:), allocatable :: exports
integer :: i
write (u, "(A)") "* Test output: rt_data_11"
write (u, "(A)") "* Purpose: handle export object list"
write (u, "(A)")
write (u, "(A)") "* Empty export list"
write (u, "(A)")
call global%write_exports (u)
write (u, "(A)") "* Add an entry"
write (u, "(A)")
allocate (exports (1))
exports(1) = var_str ("results")
do i = 1, size (exports)
write (u, "('+ ',A)") char (exports(i))
end do
write (u, *)
call global%append_exports (exports)
call global%write_exports (u)
write (u, "(A)")
write (u, "(A)") "* Add more entries, including doubler"
write (u, "(A)")
deallocate (exports)
allocate (exports (3))
exports(1) = var_str ("foo")
exports(2) = var_str ("results")
exports(3) = var_str ("bar")
do i = 1, size (exports)
write (u, "('+ ',A)") char (exports(i))
end do
write (u, *)
call global%append_exports (exports)
call global%write_exports (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: rt_data_11"
end subroutine rt_data_11
@ %def rt_data_11
@
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Select implementations}
For abstract types (process core, integrator, phase space, etc.), we need a
way to dynamically select a concrete type, using either data given by the user
or a previous selection of a concrete type. This is done by subroutines in
the current module.
We would like to put this in the [[me_methods]] folder but it also
depends on [[gosam]] and [[openloops]], so it is unclear where to put
it.
<<[[dispatch_me_methods.f90]]>>=
<<File header>>
module dispatch_me_methods
<<Use strings>>
<<Use debug>>
use physics_defs, only: BORN
use diagnostics
use sm_qcd
use variables, only: var_list_t
use models
use model_data
use prc_core_def
use prc_core
use prc_test_core
use prc_template_me
use prc_test
use prc_omega
use prc_external
use prc_gosam
use prc_openloops
use prc_recola
use prc_threshold
<<Standard module head>>
<<Dispatch ME methods: public>>
interface
<<Dispatch ME methods: sub interfaces>>
end interface
contains
<<Dispatch ME methods: main procedures>>
end module dispatch_me_methods
@ %def dispatch_me_methods
@
<<[[dispatch_me_methods_sub.f90]]>>=
<<File header>>
submodule (dispatch_me_methods) dispatch_me_methods_s
implicit none
contains
<<Dispatch ME methods: procedures>>
end submodule dispatch_me_methods_s
@ %def dispatch_me_methods_s
@
\subsection{Process Core Definition}
The [[prc_core_def_t]] abstract type can be instantiated by providing a
[[$method]] string variable.
Gfortran 7/8/9 bug, has to remain in the main module:
<<Dispatch ME methods: public>>=
public :: dispatch_core_def
<<Dispatch ME methods: main procedures>>=
subroutine dispatch_core_def (core_def, prt_in, prt_out, &
model, var_list, id, nlo_type, method)
class(prc_core_def_t), allocatable, intent(out) :: core_def
type(string_t), dimension(:), intent(in) :: prt_in
type(string_t), dimension(:), intent(in) :: prt_out
type(model_t), pointer, intent(in) :: model
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in), optional :: id
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: method
type(string_t) :: model_name, meth
type(string_t) :: ufo_path
type(string_t) :: restrictions
logical :: ufo
logical :: cms_scheme
logical :: openmp_support
logical :: report_progress
logical :: diags, diags_color
logical :: write_phs_output
type(string_t) :: extra_options, correction_type
integer :: nlo
integer :: alpha_power
integer :: alphas_power
if (present (method)) then
meth = method
else
meth = var_list%get_sval (var_str ("$method"))
end if
if (debug_on) call msg_debug2 (D_CORE, "dispatch_core_def")
if (associated (model)) then
model_name = model%get_name ()
cms_scheme = model%get_scheme () == "Complex_Mass_Scheme"
ufo = model%is_ufo_model ()
ufo_path = model%get_ufo_path ()
else
model_name = ""
cms_scheme = .false.
ufo = .false.
end if
restrictions = var_list%get_sval (&
var_str ("$restrictions"))
diags = var_list%get_lval (&
var_str ("?vis_diags"))
diags_color = var_list%get_lval (&
var_str ("?vis_diags_color"))
openmp_support = var_list%get_lval (&
var_str ("?omega_openmp"))
report_progress = var_list%get_lval (&
var_str ("?report_progress"))
write_phs_output = var_list%get_lval (&
var_str ("?omega_write_phs_output"))
extra_options = var_list%get_sval (&
var_str ("$omega_flags"))
nlo = BORN; if (present (nlo_type)) nlo = nlo_type
alpha_power = var_list%get_ival (var_str ("alpha_power"))
alphas_power = var_list%get_ival (var_str ("alphas_power"))
correction_type = var_list%get_sval (var_str ("$nlo_correction_type"))
if (debug_on) call msg_debug2 (D_CORE, "dispatching core method: ", meth)
select case (char (meth))
case ("unit_test")
allocate (prc_test_def_t :: core_def)
select type (core_def)
type is (prc_test_def_t)
call core_def%init (model_name, prt_in, prt_out)
end select
case ("template")
allocate (template_me_def_t :: core_def)
select type (core_def)
type is (template_me_def_t)
call core_def%init (model, prt_in, prt_out, unity = .false.)
end select
case ("template_unity")
allocate (template_me_def_t :: core_def)
select type (core_def)
type is (template_me_def_t)
call core_def%init (model, prt_in, prt_out, unity = .true.)
end select
case ("omega")
allocate (omega_def_t :: core_def)
select type (core_def)
type is (omega_def_t)
call core_def%init (model_name, prt_in, prt_out, &
.false., ufo, ufo_path, &
restrictions, cms_scheme, &
openmp_support, report_progress, write_phs_output, &
extra_options, diags, diags_color)
end select
case ("ovm")
allocate (omega_def_t :: core_def)
select type (core_def)
type is (omega_def_t)
call core_def%init (model_name, prt_in, prt_out, &
.true., .false., var_str (""), &
restrictions, cms_scheme, &
openmp_support, report_progress, write_phs_output, &
extra_options, diags, diags_color)
end select
case ("gosam")
allocate (gosam_def_t :: core_def)
select type (core_def)
type is (gosam_def_t)
if (present (id)) then
call core_def%init (id, model_name, prt_in, &
prt_out, nlo, restrictions, var_list)
else
call msg_fatal ("Dispatch GoSam def: No id!")
end if
end select
case ("openloops")
allocate (openloops_def_t :: core_def)
select type (core_def)
type is (openloops_def_t)
if (present (id)) then
call core_def%init (id, model_name, prt_in, &
prt_out, nlo, restrictions, var_list)
else
call msg_fatal ("Dispatch OpenLoops def: No id!")
end if
end select
case ("recola")
call abort_if_recola_not_active ()
allocate (recola_def_t :: core_def)
select type (core_def)
type is (recola_def_t)
if (present (id)) then
call core_def%init (id, model_name, prt_in, prt_out, &
nlo, alpha_power, alphas_power, correction_type, &
restrictions)
else
call msg_fatal ("Dispatch RECOLA def: No id!")
end if
end select
case ("dummy")
allocate (prc_external_test_def_t :: core_def)
select type (core_def)
type is (prc_external_test_def_t)
if (present (id)) then
call core_def%init (id, model_name, prt_in, prt_out)
else
call msg_fatal ("Dispatch User-Defined Test def: No id!")
end if
end select
case ("threshold")
allocate (threshold_def_t :: core_def)
select type (core_def)
type is (threshold_def_t)
if (present (id)) then
call core_def%init (id, model_name, prt_in, prt_out, &
nlo, restrictions)
else
call msg_fatal ("Dispatch Threshold def: No id!")
end if
end select
case default
call msg_fatal ("Process configuration: method '" &
// char (meth) // "' not implemented")
end select
end subroutine dispatch_core_def
@ %def dispatch_core_def
@
\subsection{Process core allocation}
Here we allocate an object of abstract type [[prc_core_t]] with a concrete
type that matches a process definition. The [[prc_omega_t]] extension
will require the current parameter set, so we take the opportunity to
grab it from the model.
Gfortran 7/8/9 bug, has to remain in the main module:
<<Dispatch ME methods: public>>=
public :: dispatch_core
<<Dispatch ME methods: main procedures>>=
subroutine dispatch_core (core, core_def, model, &
helicity_selection, qcd, use_color_factors, has_beam_pol)
class(prc_core_t), allocatable, intent(inout) :: core
class(prc_core_def_t), intent(in) :: core_def
class(model_data_t), intent(in), target, optional :: model
type(helicity_selection_t), intent(in), optional :: helicity_selection
type(qcd_t), intent(in), optional :: qcd
logical, intent(in), optional :: use_color_factors
logical, intent(in), optional :: has_beam_pol
select type (core_def)
type is (prc_test_def_t)
allocate (test_t :: core)
type is (template_me_def_t)
allocate (prc_template_me_t :: core)
select type (core)
type is (prc_template_me_t)
call core%set_parameters (model)
end select
class is (omega_def_t)
if (.not. allocated (core)) allocate (prc_omega_t :: core)
select type (core)
type is (prc_omega_t)
call core%set_parameters (model, &
helicity_selection, qcd, use_color_factors)
end select
type is (gosam_def_t)
if (.not. allocated (core)) allocate (prc_gosam_t :: core)
select type (core)
type is (prc_gosam_t)
call core%set_parameters (qcd)
end select
type is (openloops_def_t)
if (.not. allocated (core)) allocate (prc_openloops_t :: core)
select type (core)
type is (prc_openloops_t)
call core%set_parameters (qcd)
end select
type is (recola_def_t)
if (.not. allocated (core)) allocate (prc_recola_t :: core)
select type (core)
type is (prc_recola_t)
call core%set_parameters (qcd, model)
end select
type is (prc_external_test_def_t)
if (.not. allocated (core)) allocate (prc_external_test_t :: core)
select type (core)
type is (prc_external_test_t)
call core%set_parameters (qcd, model)
end select
type is (threshold_def_t)
if (.not. allocated (core)) allocate (prc_threshold_t :: core)
select type (core)
type is (prc_threshold_t)
call core%set_parameters (qcd, model)
call core%set_beam_pol (has_beam_pol)
end select
class default
call msg_bug ("Process core: unexpected process definition type")
end select
end subroutine dispatch_core
@ %def dispatch_core
@
\subsection{Process core update and restoration}
Here we take an existing object of abstract type [[prc_core_t]] and
update the parameters as given by the current state of [[model]].
Optionally, we can save the previous state as [[saved_core]]. The
second routine restores the original from the save.
(In the test case, there is no possible update.)
<<Dispatch ME methods: public>>=
public :: dispatch_core_update
public :: dispatch_core_restore
<<Dispatch ME methods: sub interfaces>>=
module subroutine dispatch_core_update &
(core, model, helicity_selection, qcd, saved_core)
class(prc_core_t), allocatable, intent(inout) :: core
class(model_data_t), intent(in), optional, target :: model
type(helicity_selection_t), intent(in), optional :: helicity_selection
type(qcd_t), intent(in), optional :: qcd
class(prc_core_t), allocatable, intent(inout), optional :: saved_core
end subroutine dispatch_core_update
module subroutine dispatch_core_restore (core, saved_core)
class(prc_core_t), allocatable, intent(inout) :: core
class(prc_core_t), allocatable, intent(inout) :: saved_core
end subroutine dispatch_core_restore
<<Dispatch ME methods: procedures>>=
module subroutine dispatch_core_update &
(core, model, helicity_selection, qcd, saved_core)
class(prc_core_t), allocatable, intent(inout) :: core
class(model_data_t), intent(in), optional, target :: model
type(helicity_selection_t), intent(in), optional :: helicity_selection
type(qcd_t), intent(in), optional :: qcd
class(prc_core_t), allocatable, intent(inout), optional :: saved_core
if (present (saved_core)) then
allocate (saved_core, source = core)
end if
select type (core)
type is (test_t)
type is (prc_omega_t)
call core%set_parameters (model, helicity_selection, qcd)
call core%activate_parameters ()
class is (prc_external_t)
call msg_message ("Updating user defined cores is not implemented yet.")
class default
call msg_bug ("Process core update: unexpected process definition type")
end select
end subroutine dispatch_core_update
module subroutine dispatch_core_restore (core, saved_core)
class(prc_core_t), allocatable, intent(inout) :: core
class(prc_core_t), allocatable, intent(inout) :: saved_core
call move_alloc (from = saved_core, to = core)
select type (core)
type is (test_t)
type is (prc_omega_t)
call core%activate_parameters ()
class default
call msg_bug ("Process core restore: unexpected process definition type")
end select
end subroutine dispatch_core_restore
@ %def dispatch_core_update dispatch_core_restore
@
\subsection{Unit Tests}
Test module, followed by the corresponding implementation module.
<<[[dispatch_ut.f90]]>>=
<<File header>>
module dispatch_ut
use unit_tests
use dispatch_uti
<<Standard module head>>
<<Dispatch: public test>>
<<Dispatch: public test auxiliary>>
contains
<<Dispatch: test driver>>
end module dispatch_ut
@ %def dispatch_ut
@
<<[[dispatch_uti.f90]]>>=
<<File header>>
module dispatch_uti
<<Use kinds>>
<<Use strings>>
use os_interface, only: os_data_t
use physics_defs, only: ELECTRON, PROTON
use sm_qcd, only: qcd_t
use flavors, only: flavor_t
use interactions, only: reset_interaction_counter
use pdg_arrays, only: pdg_array_t, assignment(=)
use prc_core_def, only: prc_core_def_t
use prc_test_core, only: test_t
use prc_core, only: prc_core_t
use prc_test, only: prc_test_def_t
use prc_omega, only: omega_def_t, prc_omega_t
use sf_mappings, only: sf_channel_t
use sf_base, only: sf_data_t, sf_config_t
use phs_base, only: phs_channel_collection_t
use variables, only: var_list_t
use model_data, only: model_data_t
use models, only: syntax_model_file_init, syntax_model_file_final
use rt_data, only: rt_data_t
use dispatch_phase_space, only: dispatch_sf_channels
use dispatch_beams, only: sf_prop_t, dispatch_qcd
use dispatch_beams, only: dispatch_sf_config, dispatch_sf_data
use dispatch_me_methods, only: dispatch_core_def, dispatch_core
use dispatch_me_methods, only: dispatch_core_update, dispatch_core_restore
use sf_base_ut, only: sf_test_data_t
<<Standard module head>>
<<Dispatch: public test auxiliary>>
<<Dispatch: test declarations>>
contains
<<Dispatch: tests>>
<<Dispatch: test auxiliary>>
end module dispatch_uti
@ %def dispatch_uti
@ API: driver for the unit tests below.
<<Dispatch: public test>>=
public :: dispatch_test
<<Dispatch: test driver>>=
subroutine dispatch_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Dispatch: execute tests>>
end subroutine dispatch_test
@ %def dispatch_test
@
\subsubsection{Select type: process definition}
<<Dispatch: execute tests>>=
call test (dispatch_1, "dispatch_1", &
"process configuration method", &
u, results)
<<Dispatch: test declarations>>=
public :: dispatch_1
<<Dispatch: tests>>=
subroutine dispatch_1 (u)
integer, intent(in) :: u
type(string_t), dimension(2) :: prt_in, prt_out
type(rt_data_t), target :: global
class(prc_core_def_t), allocatable :: core_def
write (u, "(A)") "* Test output: dispatch_1"
write (u, "(A)") "* Purpose: select process configuration method"
write (u, "(A)")
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
prt_in = [var_str ("a"), var_str ("b")]
prt_out = [var_str ("c"), var_str ("d")]
write (u, "(A)") "* Allocate core_def as prc_test_def"
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
select type (core_def)
type is (prc_test_def_t)
call core_def%write (u)
end select
deallocate (core_def)
write (u, "(A)")
write (u, "(A)") "* Allocate core_def as omega_def"
write (u, "(A)")
call global%set_string (var_str ("$method"), &
var_str ("omega"), is_known = .true.)
call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
select type (core_def)
type is (omega_def_t)
call core_def%write (u)
end select
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: dispatch_1"
end subroutine dispatch_1
@ %def dispatch_1
@
\subsubsection{Select type: process core}
<<Dispatch: execute tests>>=
call test (dispatch_2, "dispatch_2", &
"process core", &
u, results)
<<Dispatch: test declarations>>=
public :: dispatch_2
<<Dispatch: tests>>=
subroutine dispatch_2 (u)
integer, intent(in) :: u
type(string_t), dimension(2) :: prt_in, prt_out
type(rt_data_t), target :: global
class(prc_core_def_t), allocatable :: core_def
class(prc_core_t), allocatable :: core
write (u, "(A)") "* Test output: dispatch_2"
write (u, "(A)") "* Purpose: select process configuration method"
write (u, "(A)") " and allocate process core"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
prt_in = [var_str ("a"), var_str ("b")]
prt_out = [var_str ("c"), var_str ("d")]
write (u, "(A)") "* Allocate core as test_t"
write (u, "(A)")
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
call dispatch_core (core, core_def)
select type (core)
type is (test_t)
call core%write (u)
end select
deallocate (core)
deallocate (core_def)
write (u, "(A)")
write (u, "(A)") "* Allocate core as prc_omega_t"
write (u, "(A)")
call global%set_string (var_str ("$method"), &
var_str ("omega"), is_known = .true.)
call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
call global%select_model (var_str ("Test"))
call global%set_log (&
var_str ("?helicity_selection_active"), &
.true., is_known = .true.)
call global%set_real (&
var_str ("helicity_selection_threshold"), &
1e9_default, is_known = .true.)
call global%set_int (&
var_str ("helicity_selection_cutoff"), &
10, is_known = .true.)
call dispatch_core (core, core_def, &
global%model, &
global%get_helicity_selection ())
call core_def%allocate_driver (core%driver, var_str (""))
select type (core)
type is (prc_omega_t)
call core%write (u)
end select
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: dispatch_2"
end subroutine dispatch_2
@ %def dispatch_2
@
\subsubsection{Select type: structure-function data}
This is an extra dispatcher that enables the test structure
functions. This procedure should be assigned to the
[[dispatch_sf_data_extra]] hook before any tests are executed.
<<Dispatch: public test auxiliary>>=
public :: dispatch_sf_data_test
<<Dispatch: test auxiliary>>=
subroutine dispatch_sf_data_test (data, sf_method, i_beam, sf_prop, &
var_list, var_list_global, model, os_data, sqrts, pdg_in, pdg_prc, polarized)
class(sf_data_t), allocatable, intent(inout) :: data
type(string_t), intent(in) :: sf_method
integer, dimension(:), intent(in) :: i_beam
type(var_list_t), intent(in) :: var_list
type(var_list_t), intent(inout) :: var_list_global
class(model_data_t), target, intent(in) :: model
type(os_data_t), intent(in) :: os_data
real(default), intent(in) :: sqrts
type(pdg_array_t), dimension(:), intent(inout) :: pdg_in
type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc
type(sf_prop_t), intent(inout) :: sf_prop
logical, intent(in) :: polarized
select case (char (sf_method))
case ("sf_test_0", "sf_test_1")
allocate (sf_test_data_t :: data)
select type (data)
type is (sf_test_data_t)
select case (char (sf_method))
case ("sf_test_0"); call data%init (model, pdg_in(i_beam(1)))
case ("sf_test_1"); call data%init (model, pdg_in(i_beam(1)),&
mode = 1)
end select
end select
end select
end subroutine dispatch_sf_data_test
@ %def dispatch_sf_data_test
@ The actual test. We can't move this to [[beams]] as it depends on
[[model_features]] for the [[model_list_t]].
<<Dispatch: execute tests>>=
call test (dispatch_7, "dispatch_7", &
"structure-function data", &
u, results)
<<Dispatch: test declarations>>=
public :: dispatch_7
<<Dispatch: tests>>=
subroutine dispatch_7 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
type(os_data_t) :: os_data
type(string_t) :: prt, sf_method
type(sf_prop_t) :: sf_prop
class(sf_data_t), allocatable :: data
type(pdg_array_t), dimension(1) :: pdg_in
type(pdg_array_t), dimension(1,1) :: pdg_prc
type(pdg_array_t), dimension(1) :: pdg_out
integer, dimension(:), allocatable :: pdg1
write (u, "(A)") "* Test output: dispatch_7"
write (u, "(A)") "* Purpose: select and configure &
&structure function data"
write (u, "(A)")
call global%global_init ()
call os_data%init ()
call syntax_model_file_init ()
call global%select_model (var_str ("QCD"))
call reset_interaction_counter ()
call global%set_real (var_str ("sqrts"), &
14000._default, is_known = .true.)
prt = "p"
call global%beam_structure%init_sf ([prt, prt], [1])
pdg_in = 2212
write (u, "(A)") "* Allocate data as sf_pdf_builtin_t"
write (u, "(A)")
sf_method = "pdf_builtin"
call dispatch_sf_data (data, sf_method, [1], sf_prop, &
global%get_var_list_ptr (), global%var_list, &
global%model, global%os_data, global%get_sqrts (), &
pdg_in, pdg_prc, .false.)
call data%write (u)
call data%get_pdg_out (pdg_out)
pdg1 = pdg_out(1)
write (u, "(A)")
write (u, "(1x,A,99(1x,I0))") "PDG(out) = ", pdg1
deallocate (data)
write (u, "(A)")
write (u, "(A)") "* Allocate data for different PDF set"
write (u, "(A)")
pdg_in = 2212
call global%set_string (var_str ("$pdf_builtin_set"), &
var_str ("CTEQ6M"), is_known = .true.)
sf_method = "pdf_builtin"
call dispatch_sf_data (data, sf_method, [1], sf_prop, &
global%get_var_list_ptr (), global%var_list, &
global%model, global%os_data, global%get_sqrts (), &
pdg_in, pdg_prc, .false.)
call data%write (u)
call data%get_pdg_out (pdg_out)
pdg1 = pdg_out(1)
write (u, "(A)")
write (u, "(1x,A,99(1x,I0))") "PDG(out) = ", pdg1
deallocate (data)
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: dispatch_7"
end subroutine dispatch_7
@ %def dispatch_7
@
\subsubsection{Beam structure}
The actual test. We can't move this to [[beams]] as it depends on
[[model_features]] for the [[model_list_t]].
<<Dispatch: execute tests>>=
call test (dispatch_8, "dispatch_8", &
"beam structure", &
u, results)
<<Dispatch: test declarations>>=
public :: dispatch_8
<<Dispatch: tests>>=
subroutine dispatch_8 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
type(os_data_t) :: os_data
type(flavor_t), dimension(2) :: flv
type(sf_config_t), dimension(:), allocatable :: sf_config
type(sf_prop_t) :: sf_prop
type(sf_channel_t), dimension(:), allocatable :: sf_channel
type(phs_channel_collection_t) :: coll
type(string_t) :: sf_string
integer :: i
type(pdg_array_t), dimension (2,1) :: pdg_prc
write (u, "(A)") "* Test output: dispatch_8"
write (u, "(A)") "* Purpose: configure a structure-function chain"
write (u, "(A)")
call global%global_init ()
call os_data%init ()
call syntax_model_file_init ()
call global%select_model (var_str ("QCD"))
write (u, "(A)") "* Allocate LHC beams with PDF builtin"
write (u, "(A)")
call flv(1)%init (PROTON, global%model)
call flv(2)%init (PROTON, global%model)
call reset_interaction_counter ()
call global%set_real (var_str ("sqrts"), &
14000._default, is_known = .true.)
call global%beam_structure%init_sf (flv%get_name (), [1])
call global%beam_structure%set_sf (1, 1, var_str ("pdf_builtin"))
call dispatch_sf_config (sf_config, sf_prop, global%beam_structure, &
global%get_var_list_ptr (), global%var_list, &
global%model, global%os_data, global%get_sqrts (), pdg_prc)
do i = 1, size (sf_config)
call sf_config(i)%write (u)
end do
call dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, &
global%var_list, global%get_sqrts(), global%beam_structure)
write (u, "(1x,A)") "Mapping configuration:"
do i = 1, size (sf_channel)
write (u, "(2x)", advance = "no")
call sf_channel(i)%write (u)
end do
write (u, "(A)")
write (u, "(A)") "* Allocate ILC beams with CIRCE1"
write (u, "(A)")
call global%select_model (var_str ("QED"))
call flv(1)%init ( ELECTRON, global%model)
call flv(2)%init (-ELECTRON, global%model)
call reset_interaction_counter ()
call global%set_real (var_str ("sqrts"), &
500._default, is_known = .true.)
call global%set_log (var_str ("?circe1_generate"), &
.false., is_known = .true.)
call global%beam_structure%init_sf (flv%get_name (), [1])
call global%beam_structure%set_sf (1, 1, var_str ("circe1"))
call dispatch_sf_config (sf_config, sf_prop, global%beam_structure, &
global%get_var_list_ptr (), global%var_list, &
global%model, global%os_data, global%get_sqrts (), pdg_prc)
do i = 1, size (sf_config)
call sf_config(i)%write (u)
end do
call dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, &
global%var_list, global%get_sqrts(), global%beam_structure)
write (u, "(1x,A)") "Mapping configuration:"
do i = 1, size (sf_channel)
write (u, "(2x)", advance = "no")
call sf_channel(i)%write (u)
end do
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: dispatch_8"
end subroutine dispatch_8
@ %def dispatch_8
@
\subsubsection{Update process core parameters}
This test dispatches a process core, temporarily modifies parameters,
then restores the original.
<<Dispatch: execute tests>>=
call test (dispatch_10, "dispatch_10", &
"process core update", &
u, results)
<<Dispatch: test declarations>>=
public :: dispatch_10
<<Dispatch: tests>>=
subroutine dispatch_10 (u)
integer, intent(in) :: u
type(string_t), dimension(2) :: prt_in, prt_out
type(rt_data_t), target :: global
class(prc_core_def_t), allocatable :: core_def
class(prc_core_t), allocatable :: core, saved_core
type(var_list_t), pointer :: model_vars
write (u, "(A)") "* Test output: dispatch_10"
write (u, "(A)") "* Purpose: select process configuration method,"
write (u, "(A)") " allocate process core,"
write (u, "(A)") " temporarily reset parameters"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
prt_in = [var_str ("a"), var_str ("b")]
prt_out = [var_str ("c"), var_str ("d")]
write (u, "(A)") "* Allocate core as prc_omega_t"
write (u, "(A)")
call global%set_string (var_str ("$method"), &
var_str ("omega"), is_known = .true.)
call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
call global%select_model (var_str ("Test"))
call dispatch_core (core, core_def, global%model)
call core_def%allocate_driver (core%driver, var_str (""))
select type (core)
type is (prc_omega_t)
call core%write (u)
end select
write (u, "(A)")
write (u, "(A)") "* Update core with modified model and helicity selection"
write (u, "(A)")
model_vars => global%model%get_var_list_ptr ()
call model_vars%set_real (var_str ("gy"), 2._default, &
is_known = .true.)
call global%model%update_parameters ()
call global%set_log (&
var_str ("?helicity_selection_active"), &
.true., is_known = .true.)
call global%set_real (&
var_str ("helicity_selection_threshold"), &
2e10_default, is_known = .true.)
call global%set_int (&
var_str ("helicity_selection_cutoff"), &
5, is_known = .true.)
call dispatch_core_update (core, &
global%model, &
global%get_helicity_selection (), &
saved_core = saved_core)
select type (core)
type is (prc_omega_t)
call core%write (u)
end select
write (u, "(A)")
write (u, "(A)") "* Restore core from save"
write (u, "(A)")
call dispatch_core_restore (core, saved_core)
select type (core)
type is (prc_omega_t)
call core%write (u)
end select
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: dispatch_10"
end subroutine dispatch_10
@ %def dispatch_10
@
\subsubsection{QCD Coupling}
This test dispatches an [[qcd]] object, which is used to compute the
(running) coupling by one of several possible methods.
We can't move this to [[beams]] as it depends on
[[model_features]] for the [[model_list_t]].
<<Dispatch: execute tests>>=
call test (dispatch_11, "dispatch_11", &
"QCD coupling", &
u, results)
<<Dispatch: test declarations>>=
public :: dispatch_11
<<Dispatch: tests>>=
subroutine dispatch_11 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
type(var_list_t), pointer :: model_vars
type(qcd_t) :: qcd
write (u, "(A)") "* Test output: dispatch_11"
write (u, "(A)") "* Purpose: select QCD coupling formula"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%select_model (var_str ("SM"))
model_vars => global%get_var_list_ptr ()
write (u, "(A)") "* Allocate alpha_s as fixed"
write (u, "(A)")
call global%set_log (var_str ("?alphas_is_fixed"), &
.true., is_known = .true.)
call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
call qcd%write (u)
write (u, "(A)")
write (u, "(A)") "* Allocate alpha_s as running (built-in)"
write (u, "(A)")
call global%set_log (var_str ("?alphas_is_fixed"), &
.false., is_known = .true.)
call global%set_log (var_str ("?alphas_from_mz"), &
.true., is_known = .true.)
call global%set_int &
(var_str ("alphas_order"), 1, is_known = .true.)
call model_vars%set_real (var_str ("alphas"), 0.1234_default, &
is_known=.true.)
call model_vars%set_real (var_str ("mZ"), 91.234_default, &
is_known=.true.)
call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
call qcd%write (u)
write (u, "(A)")
write (u, "(A)") "* Allocate alpha_s as running (built-in, Lambda defined)"
write (u, "(A)")
call global%set_log (var_str ("?alphas_from_mz"), &
.false., is_known = .true.)
call global%set_log (&
var_str ("?alphas_from_lambda_qcd"), &
.true., is_known = .true.)
call global%set_real &
(var_str ("lambda_qcd"), 250.e-3_default, &
is_known=.true.)
call global%set_int &
(var_str ("alphas_order"), 2, is_known = .true.)
call global%set_int &
(var_str ("alphas_nf"), 4, is_known = .true.)
call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
call qcd%write (u)
write (u, "(A)")
write (u, "(A)") "* Allocate alpha_s as running (using builtin PDF set)"
write (u, "(A)")
call global%set_log (&
var_str ("?alphas_from_lambda_qcd"), &
.false., is_known = .true.)
call global%set_log &
(var_str ("?alphas_from_pdf_builtin"), &
.true., is_known = .true.)
call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
call qcd%write (u)
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: dispatch_11"
end subroutine dispatch_11
@ %def dispatch_11
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Process Configuration}
This module communicates between the toplevel command structure with
its runtime data set and the process-library handling modules which
collect the definition of individual processes. Its primary purpose
is to select from the available matrix-element generating methods and
configure the entry in the process library accordingly.
<<[[process_configurations.f90]]>>=
<<File header>>
module process_configurations
<<Use strings>>
use models
use particle_specifiers
use process_libraries
use rt_data
use variables, only: var_list_t
<<Standard module head>>
<<Process configurations: public>>
<<Process configurations: types>>
interface
<<Process configurations: sub interfaces>>
end interface
end module process_configurations
@ %def process_configurations
@
<<[[process_configurations_sub.f90]]>>=
<<File header>>
submodule (process_configurations) process_configurations_s
<<Use debug>>
use diagnostics
use io_units
use physics_defs, only: BORN, NLO_VIRTUAL, NLO_REAL, NLO_DGLAP, &
NLO_SUBTRACTION, NLO_MISMATCH
use prc_core_def
use dispatch_me_methods, only: dispatch_core_def
use prc_external, only: prc_external_def_t
implicit none
contains
<<Process configurations: procedures>>
end submodule process_configurations_s
@ %def process_configurations_s
@
\subsection{Data Type}
<<Process configurations: public>>=
public :: process_configuration_t
<<Process configurations: types>>=
type :: process_configuration_t
type(process_def_entry_t), pointer :: entry => null ()
type(string_t) :: id
integer :: num_id = 0
contains
<<Process configurations: process configuration: TBP>>
end type process_configuration_t
@ %def process_configuration_t
@ Output (for unit tests).
<<Process configurations: process configuration: TBP>>=
procedure :: write => process_configuration_write
<<Process configurations: sub interfaces>>=
module subroutine process_configuration_write (config, unit)
class(process_configuration_t), intent(in) :: config
integer, intent(in), optional :: unit
end subroutine process_configuration_write
<<Process configurations: procedures>>=
module subroutine process_configuration_write (config, unit)
class(process_configuration_t), intent(in) :: config
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(A)") "Process configuration:"
if (associated (config%entry)) then
call config%entry%write (u)
else
write (u, "(1x,3A)") "ID = '", char (config%id), "'"
write (u, "(1x,A,1x,I0)") "num ID =", config%num_id
write (u, "(2x,A)") "[no entry]"
end if
end subroutine process_configuration_write
@ %def process_configuration_write
@ Initialize a process. We only need the name, the number of incoming
particles, and the number of components.
<<Process configurations: process configuration: TBP>>=
procedure :: init => process_configuration_init
<<Process configurations: sub interfaces>>=
module subroutine process_configuration_init &
(config, prc_name, n_in, n_components, model, var_list, &
nlo_process, negative_sf)
class(process_configuration_t), intent(out) :: config
type(string_t), intent(in) :: prc_name
integer, intent(in) :: n_in
integer, intent(in) :: n_components
type(model_t), intent(in), pointer :: model
type(var_list_t), intent(in) :: var_list
logical, intent(in), optional :: nlo_process, negative_sf
end subroutine process_configuration_init
<<Process configurations: procedures>>=
module subroutine process_configuration_init &
(config, prc_name, n_in, n_components, model, var_list, &
nlo_process, negative_sf)
class(process_configuration_t), intent(out) :: config
type(string_t), intent(in) :: prc_name
integer, intent(in) :: n_in
integer, intent(in) :: n_components
type(model_t), intent(in), pointer :: model
type(var_list_t), intent(in) :: var_list
logical, intent(in), optional :: nlo_process, negative_sf
logical :: nlo_proc, neg_sf
logical :: requires_resonances
if (debug_on) call msg_debug (D_CORE, "process_configuration_init")
config%id = prc_name
if (present (nlo_process)) then
nlo_proc = nlo_process
else
nlo_proc = .false.
end if
if (present (negative_sf)) then
neg_sf = negative_sf
else
neg_sf = .false.
end if
requires_resonances = var_list%get_lval (var_str ("?resonance_history"))
if (debug_on) call msg_debug (D_CORE, "nlo_process", nlo_proc)
allocate (config%entry)
if (var_list%is_known (var_str ("process_num_id"))) then
config%num_id = &
var_list%get_ival (var_str ("process_num_id"))
call config%entry%init (prc_name, &
model = model, n_in = n_in, n_components = n_components, &
num_id = config%num_id, &
nlo_process = nlo_proc, &
negative_sf = neg_sf, &
requires_resonances = requires_resonances)
else
call config%entry%init (prc_name, &
model = model, n_in = n_in, n_components = n_components, &
nlo_process = nlo_proc, &
negative_sf = neg_sf, &
requires_resonances = requires_resonances)
end if
end subroutine process_configuration_init
@ %def process_configuration_init
@ Initialize a process component. The details depend on the process method,
which determines the type of the process component core. We set the incoming
and outgoing particles (as strings, to be interpreted by the process driver).
All other information is taken from the variable list.
The dispatcher gets only the names of the particles. The process
component definition gets the complete specifiers which contains a
polarization flag and names of decay processes, where applicable.
<<Process configurations: process configuration: TBP>>=
procedure :: setup_component => process_configuration_setup_component
<<Process configurations: sub interfaces>>=
module subroutine process_configuration_setup_component &
(config, i_component, prt_in, prt_out, model, var_list, &
nlo_type, can_be_integrated)
class(process_configuration_t), intent(inout) :: config
integer, intent(in) :: i_component
type(prt_spec_t), dimension(:), intent(in) :: prt_in
type(prt_spec_t), dimension(:), intent(in) :: prt_out
type(model_t), pointer, intent(in) :: model
type(var_list_t), intent(in) :: var_list
integer, intent(in), optional :: nlo_type
logical, intent(in), optional :: can_be_integrated
end subroutine process_configuration_setup_component
<<Process configurations: procedures>>=
module subroutine process_configuration_setup_component &
(config, i_component, prt_in, prt_out, model, var_list, &
nlo_type, can_be_integrated)
class(process_configuration_t), intent(inout) :: config
integer, intent(in) :: i_component
type(prt_spec_t), dimension(:), intent(in) :: prt_in
type(prt_spec_t), dimension(:), intent(in) :: prt_out
type(model_t), pointer, intent(in) :: model
type(var_list_t), intent(in) :: var_list
integer, intent(in), optional :: nlo_type
logical, intent(in), optional :: can_be_integrated
type(string_t), dimension(:), allocatable :: prt_str_in
type(string_t), dimension(:), allocatable :: prt_str_out
class(prc_core_def_t), allocatable :: core_def
type(string_t) :: method
type(string_t) :: born_me_method
type(string_t) :: real_tree_me_method
type(string_t) :: loop_me_method
type(string_t) :: correlation_me_method
type(string_t) :: dglap_me_method
integer :: i
if (debug_on) call msg_debug2 &
(D_CORE, "process_configuration_setup_component")
allocate (prt_str_in (size (prt_in)))
allocate (prt_str_out (size (prt_out)))
forall (i = 1:size (prt_in)) prt_str_in(i) = prt_in(i)% get_name ()
forall (i = 1:size (prt_out)) prt_str_out(i) = prt_out(i)%get_name ()
method = var_list%get_sval (var_str ("$method"))
if (present (nlo_type)) then
select case (nlo_type)
case (BORN)
born_me_method = var_list%get_sval (var_str ("$born_me_method"))
if (born_me_method /= var_str ("")) then
method = born_me_method
end if
case (NLO_VIRTUAL)
loop_me_method = var_list%get_sval (var_str ("$loop_me_method"))
if (loop_me_method /= var_str ("")) then
method = loop_me_method
end if
case (NLO_REAL)
real_tree_me_method = &
var_list%get_sval (var_str ("$real_tree_me_method"))
if (real_tree_me_method /= var_str ("")) then
method = real_tree_me_method
end if
case (NLO_DGLAP)
dglap_me_method = &
var_list%get_sval (var_str ("$dglap_me_method"))
if (dglap_me_method /= var_str ("")) then
method = dglap_me_method
end if
case (NLO_SUBTRACTION,NLO_MISMATCH)
correlation_me_method = &
var_list%get_sval (var_str ("$correlation_me_method"))
if (correlation_me_method /= var_str ("")) then
method = correlation_me_method
end if
case default
end select
end if
call dispatch_core_def (core_def, prt_str_in, prt_str_out, &
model, var_list, config%id, nlo_type, method)
select type (core_def)
class is (prc_external_def_t)
if (present (can_be_integrated)) then
call core_def%set_active_writer (can_be_integrated)
else
call msg_fatal ("Cannot decide if external core is integrated!")
end if
end select
if (debug_on) call msg_debug2 &
(D_CORE, "import_component with method ", method)
call config%entry%import_component (i_component, &
n_out = size (prt_out), &
prt_in = prt_in, &
prt_out = prt_out, &
method = method, &
variant = core_def, &
nlo_type = nlo_type, &
can_be_integrated = can_be_integrated)
end subroutine process_configuration_setup_component
@ %def process_configuration_setup_component
@
<<Process configurations: process configuration: TBP>>=
procedure :: set_fixed_emitter => process_configuration_set_fixed_emitter
<<Process configurations: sub interfaces>>=
module subroutine process_configuration_set_fixed_emitter &
(config, i, emitter)
class(process_configuration_t), intent(inout) :: config
integer, intent(in) :: i, emitter
end subroutine process_configuration_set_fixed_emitter
<<Process configurations: procedures>>=
module subroutine process_configuration_set_fixed_emitter (config, i, emitter)
class(process_configuration_t), intent(inout) :: config
integer, intent(in) :: i, emitter
call config%entry%set_fixed_emitter (i, emitter)
end subroutine process_configuration_set_fixed_emitter
@ %def process_configuration_set_fixed_emitter
@
<<Process configurations: process configuration: TBP>>=
procedure :: set_coupling_powers => process_configuration_set_coupling_powers
<<Process configurations: sub interfaces>>=
module subroutine process_configuration_set_coupling_powers &
(config, alpha_power, alphas_power)
class(process_configuration_t), intent(inout) :: config
integer, intent(in) :: alpha_power, alphas_power
end subroutine process_configuration_set_coupling_powers
<<Process configurations: procedures>>=
module subroutine process_configuration_set_coupling_powers &
(config, alpha_power, alphas_power)
class(process_configuration_t), intent(inout) :: config
integer, intent(in) :: alpha_power, alphas_power
call config%entry%set_coupling_powers (alpha_power, alphas_power)
end subroutine process_configuration_set_coupling_powers
@ %def process_configuration_set_coupling_powers
@
<<Process configurations: process configuration: TBP>>=
procedure :: set_component_associations => &
process_configuration_set_component_associations
<<Process configurations: sub interfaces>>=
module subroutine process_configuration_set_component_associations &
(config, i_list, remnant, use_real_finite, mismatch)
class(process_configuration_t), intent(inout) :: config
integer, dimension(:), intent(in) :: i_list
logical, intent(in) :: remnant, use_real_finite, mismatch
end subroutine process_configuration_set_component_associations
<<Process configurations: procedures>>=
module subroutine process_configuration_set_component_associations &
(config, i_list, remnant, use_real_finite, mismatch)
class(process_configuration_t), intent(inout) :: config
integer, dimension(:), intent(in) :: i_list
logical, intent(in) :: remnant, use_real_finite, mismatch
integer :: i_component
do i_component = 1, config%entry%get_n_components ()
if (any (i_list == i_component)) then
call config%entry%set_associated_components (i_component, &
i_list, remnant, use_real_finite, mismatch)
end if
end do
end subroutine process_configuration_set_component_associations
@ %def process_configuration_set_component_associations
@ Record a process configuration: append it to the currently selected process
definition library.
<<Process configurations: process configuration: TBP>>=
procedure :: record => process_configuration_record
<<Process configurations: sub interfaces>>=
module subroutine process_configuration_record (config, global)
class(process_configuration_t), intent(inout) :: config
type(rt_data_t), intent(inout) :: global
end subroutine process_configuration_record
<<Process configurations: procedures>>=
module subroutine process_configuration_record (config, global)
class(process_configuration_t), intent(inout) :: config
type(rt_data_t), intent(inout) :: global
if (associated (global%prclib)) then
call global%prclib%open ()
call global%prclib%append (config%entry)
if (config%num_id /= 0) then
write (msg_buffer, "(5A,I0,A)") "Process library '", &
char (global%prclib%get_name ()), &
"': recorded process '", char (config%id), "' (", &
config%num_id, ")"
else
write (msg_buffer, "(5A)") "Process library '", &
char (global%prclib%get_name ()), &
"': recorded process '", char (config%id), "'"
end if
call msg_message ()
else
call msg_fatal ("Recording process '" // char (config%id) &
// "': active process library undefined")
end if
end subroutine process_configuration_record
@ %def process_configuration_record
@
\subsection{Unit Tests}
Test module, followed by the corresponding implementation module.
<<[[process_configurations_ut.f90]]>>=
<<File header>>
module process_configurations_ut
use unit_tests
use process_configurations_uti
<<Standard module head>>
<<Process configurations: public test>>
<<Process configurations: public test auxiliary>>
contains
<<Process configurations: test driver>>
end module process_configurations_ut
@ %def process_configurations_ut
@
<<[[process_configurations_uti.f90]]>>=
<<File header>>
module process_configurations_uti
<<Use strings>>
use particle_specifiers, only: new_prt_spec
use prclib_stacks
use models
use rt_data
use process_configurations
<<Standard module head>>
<<Process configurations: test declarations>>
<<Process configurations: public test auxiliary>>
contains
<<Process configurations: test auxiliary>>
<<Process configurations: tests>>
end module process_configurations_uti
@ %def process_configurations_uti
@ API: driver for the unit tests below.
<<Process configurations: public test>>=
public :: process_configurations_test
<<Process configurations: test driver>>=
subroutine process_configurations_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Process configurations: execute tests>>
end subroutine process_configurations_test
@ %def process_configurations_test
@
\subsubsection{Minimal setup}
The workflow for setting up a minimal process configuration with the
test matrix element method.
We wrap this in a public procedure, so we can reuse it in later modules.
The procedure prepares a process definition list for two processes
(one [[prc_test]] and one [[omega]] type) and appends this to the
process library stack in the global data set.
The [[mode]] argument determines which processes to build.
The [[procname]] argument replaces the predefined procname(s).
This is re-exported by the UT module.
<<Process configurations: public test auxiliary>>=
public :: prepare_test_library
<<Process configurations: test auxiliary>>=
subroutine prepare_test_library (global, libname, mode, procname)
type(rt_data_t), intent(inout), target :: global
type(string_t), intent(in) :: libname
integer, intent(in) :: mode
type(string_t), intent(in), dimension(:), optional :: procname
type(prclib_entry_t), pointer :: lib
type(string_t) :: prc_name
type(string_t), dimension(:), allocatable :: prt_in, prt_out
integer :: n_components
type(process_configuration_t) :: prc_config
if (.not. associated (global%prclib_stack%get_first_ptr ())) then
allocate (lib)
call lib%init (libname)
call global%add_prclib (lib)
end if
if (btest (mode, 0)) then
call global%select_model (var_str ("Test"))
if (present (procname)) then
prc_name = procname(1)
else
prc_name = "prc_config_a"
end if
n_components = 1
allocate (prt_in (2), prt_out (2))
prt_in = [var_str ("s"), var_str ("s")]
prt_out = [var_str ("s"), var_str ("s")]
call global%set_string (var_str ("$method"),&
var_str ("unit_test"), is_known = .true.)
call prc_config%init (prc_name, &
size (prt_in), n_components, &
global%model, global%var_list)
call prc_config%setup_component (1, &
new_prt_spec (prt_in), new_prt_spec (prt_out), &
global%model, global%var_list)
call prc_config%record (global)
deallocate (prt_in, prt_out)
end if
if (btest (mode, 1)) then
call global%select_model (var_str ("QED"))
if (present (procname)) then
prc_name = procname(2)
else
prc_name = "prc_config_b"
end if
n_components = 1
allocate (prt_in (2), prt_out (2))
prt_in = [var_str ("e+"), var_str ("e-")]
prt_out = [var_str ("m+"), var_str ("m-")]
call global%set_string (var_str ("$method"),&
var_str ("omega"), is_known = .true.)
call prc_config%init (prc_name, &
size (prt_in), n_components, &
global%model, global%var_list)
call prc_config%setup_component (1, &
new_prt_spec (prt_in), new_prt_spec (prt_out), &
global%model, global%var_list)
call prc_config%record (global)
deallocate (prt_in, prt_out)
end if
if (btest (mode, 2)) then
call global%select_model (var_str ("Test"))
if (present (procname)) then
prc_name = procname(1)
else
prc_name = "prc_config_a"
end if
n_components = 1
allocate (prt_in (1), prt_out (2))
prt_in = [var_str ("s")]
prt_out = [var_str ("f"), var_str ("fbar")]
call global%set_string (var_str ("$method"),&
var_str ("unit_test"), is_known = .true.)
call prc_config%init (prc_name, &
size (prt_in), n_components, &
global%model, global%var_list)
call prc_config%setup_component (1, &
new_prt_spec (prt_in), new_prt_spec (prt_out), &
global%model, global%var_list)
call prc_config%record (global)
deallocate (prt_in, prt_out)
end if
end subroutine prepare_test_library
@ %def prepare_test_library
@ The actual test: the previous procedure with some prelude and postlude.
In the global variable list, just before printing we reset the
variables where the value may depend on the system and run environment.
<<Process configurations: execute tests>>=
call test (process_configurations_1, "process_configurations_1", &
"test processes", &
u, results)
<<Process configurations: test declarations>>=
public :: process_configurations_1
<<Process configurations: tests>>=
subroutine process_configurations_1 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
write (u, "(A)") "* Test output: process_configurations_1"
write (u, "(A)") "* Purpose: configure test processes"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
write (u, "(A)") "* Configure processes as prc_test, model Test"
write (u, "(A)") "* and omega, model QED"
write (u, *)
call global%set_int (var_str ("process_num_id"), &
42, is_known = .true.)
call prepare_test_library (global, var_str ("prc_config_lib_1"), 3)
global%os_data%fc = "Fortran-compiler"
global%os_data%fcflags = "Fortran-flags"
global%os_data%fclibs = "Fortran-libs"
call global%write_libraries (u)
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: process_configurations_1"
end subroutine process_configurations_1
@ %def process_configurations_1
@
\subsubsection{\oMega\ options}
Slightly extended example where we pass \oMega\ options to the
library. The [[prepare_test_library]] contents are spelled out.
<<Process configurations: execute tests>>=
call test (process_configurations_2, "process_configurations_2", &
"omega options", &
u, results)
<<Process configurations: test declarations>>=
public :: process_configurations_2
<<Process configurations: tests>>=
subroutine process_configurations_2 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
type(string_t) :: libname
type(prclib_entry_t), pointer :: lib
type(string_t) :: prc_name
type(string_t), dimension(:), allocatable :: prt_in, prt_out
integer :: n_components
type(process_configuration_t) :: prc_config
write (u, "(A)") "* Test output: process_configurations_2"
write (u, "(A)") "* Purpose: configure test processes with options"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
write (u, "(A)") "* Configure processes as omega, model QED"
write (u, *)
libname = "prc_config_lib_2"
allocate (lib)
call lib%init (libname)
call global%add_prclib (lib)
call global%select_model (var_str ("QED"))
prc_name = "prc_config_c"
n_components = 2
allocate (prt_in (2), prt_out (2))
prt_in = [var_str ("e+"), var_str ("e-")]
prt_out = [var_str ("m+"), var_str ("m-")]
call global%set_string (var_str ("$method"),&
var_str ("omega"), is_known = .true.)
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call prc_config%init (prc_name, size (prt_in), n_components, &
global%model, global%var_list)
call global%set_log (var_str ("?report_progress"), &
.true., is_known = .true.)
call prc_config%setup_component (1, &
new_prt_spec (prt_in), new_prt_spec (prt_out), global%model, global%var_list)
call global%set_log (var_str ("?report_progress"), &
.false., is_known = .true.)
call global%set_log (var_str ("?omega_openmp"), &
.true., is_known = .true.)
call global%set_string (var_str ("$restrictions"),&
var_str ("3+4~A"), is_known = .true.)
call global%set_string (var_str ("$omega_flags"), &
var_str ("-fusion:progress_file omega_prc_config.log"), &
is_known = .true.)
call prc_config%setup_component (2, &
new_prt_spec (prt_in), new_prt_spec (prt_out), global%model, global%var_list)
call prc_config%record (global)
deallocate (prt_in, prt_out)
global%os_data%fc = "Fortran-compiler"
global%os_data%fcflags = "Fortran-flags"
global%os_data%fclibs = "Fortran-libs"
call global%write_vars (u, [ &
var_str ("$model_name"), &
var_str ("$method"), &
var_str ("?report_progress"), &
var_str ("$restrictions"), &
var_str ("$omega_flags")])
write (u, "(A)")
call global%write_libraries (u)
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: process_configurations_2"
end subroutine process_configurations_2
@ %def process_configurations_2
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Compilation}
This module manages compilation and loading of of process libraries. It is
needed as a separate module because integration depends on it.
<<[[compilations.f90]]>>=
<<File header>>
module compilations
<<Use strings>>
use os_interface
use variables, only: var_list_t
use model_data
use process_libraries
use prclib_stacks
use rt_data
<<Standard module head>>
<<Compilations: public>>
<<Compilations: types>>
<<Compilations: parameters>>
interface
<<Compilations: sub interfaces>>
end interface
end module compilations
@ %def compilations
@
<<[[compilations_sub.f90]]>>=
<<File header>>
submodule (compilations) compilations_s
use io_units
use system_defs, only: TAB
use system_dependencies, only: OS_IS_DARWIN
use diagnostics
implicit none
contains
<<Compilations: procedures>>
end submodule compilations_s
@ %def compilations_s
@
\subsection{The data type}
The compilation item handles the compilation and loading of a single
process library.
<<Compilations: public>>=
public :: compilation_item_t
<<Compilations: types>>=
type :: compilation_item_t
private
type(string_t) :: libname
type(string_t) :: static_external_tag
type(process_library_t), pointer :: lib => null ()
logical :: recompile_library = .false.
logical :: verbose = .false.
logical :: use_workspace = .false.
type(string_t) :: workspace
contains
<<Compilations: compilation item: TBP>>
end type compilation_item_t
@ %def compilation_item_t
@ Initialize.
Set flags and global properties of the library. Establish the workspace name,
if defined.
<<Compilations: compilation item: TBP>>=
procedure :: init => compilation_item_init
<<Compilations: sub interfaces>>=
module subroutine compilation_item_init (comp, libname, stack, var_list)
class(compilation_item_t), intent(out) :: comp
type(string_t), intent(in) :: libname
type(prclib_stack_t), intent(inout) :: stack
type(var_list_t), intent(in) :: var_list
end subroutine compilation_item_init
<<Compilations: procedures>>=
module subroutine compilation_item_init (comp, libname, stack, var_list)
class(compilation_item_t), intent(out) :: comp
type(string_t), intent(in) :: libname
type(prclib_stack_t), intent(inout) :: stack
type(var_list_t), intent(in) :: var_list
comp%libname = libname
comp%lib => stack%get_library_ptr (comp%libname)
if (.not. associated (comp%lib)) then
call msg_fatal ("Process library '" // char (comp%libname) &
// "' has not been declared.")
end if
comp%recompile_library = &
var_list%get_lval (var_str ("?recompile_library"))
comp%verbose = &
var_list%get_lval (var_str ("?me_verbose"))
comp%use_workspace = &
var_list%is_known (var_str ("$compile_workspace"))
if (comp%use_workspace) then
comp%workspace = &
var_list%get_sval (var_str ("$compile_workspace"))
if (comp%workspace == "") comp%use_workspace = .false.
else
comp%workspace = ""
end if
end subroutine compilation_item_init
@ %def compilation_item_init
@ Compile the current library. The [[force]] flag has the
effect that we first delete any previous files, as far as accessible
by the current makefile. It also guarantees that previous files not
accessible by a makefile will be overwritten.
<<Compilations: compilation item: TBP>>=
procedure :: compile => compilation_item_compile
<<Compilations: sub interfaces>>=
module subroutine compilation_item_compile &
(comp, model, os_data, force, recompile)
class(compilation_item_t), intent(inout) :: comp
class(model_data_t), intent(in), target :: model
type(os_data_t), intent(in) :: os_data
logical, intent(in) :: force, recompile
end subroutine compilation_item_compile
<<Compilations: procedures>>=
module subroutine compilation_item_compile &
(comp, model, os_data, force, recompile)
class(compilation_item_t), intent(inout) :: comp
class(model_data_t), intent(in), target :: model
type(os_data_t), intent(in) :: os_data
logical, intent(in) :: force, recompile
if (associated (comp%lib)) then
if (comp%use_workspace) call setup_workspace (comp%workspace, os_data)
call msg_message ("Process library '" &
// char (comp%libname) // "': compiling ...")
call comp%lib%configure (os_data)
if (signal_is_pending ()) return
call comp%lib%compute_md5sum (model)
call comp%lib%write_makefile &
(os_data, force, verbose=comp%verbose, workspace=comp%workspace)
if (signal_is_pending ()) return
if (force) then
call comp%lib%clean &
(os_data, distclean = .false., workspace=comp%workspace)
if (signal_is_pending ()) return
end if
call comp%lib%write_driver (force, workspace=comp%workspace)
if (signal_is_pending ()) return
if (recompile) then
call comp%lib%load &
(os_data, keep_old_source = .true., workspace=comp%workspace)
if (signal_is_pending ()) return
end if
call comp%lib%update_status (os_data, workspace=comp%workspace)
end if
end subroutine compilation_item_compile
@ %def compilation_item_compile
@ The workspace directory is created if it does not exist. (Applies only if
the use has set the workspace directory.)
<<Compilations: parameters>>=
character(*), parameter :: ALLOWED_IN_DIRNAME = &
"abcdefghijklmnopqrstuvwxyz&
&ABCDEFGHIJKLMNOPQRSTUVWXYZ&
&1234567890&
&.,_-+="
@ %def ALLOWED_IN_DIRNAME
<<Compilations: procedures>>=
subroutine setup_workspace (workspace, os_data)
type(string_t), intent(in) :: workspace
type(os_data_t), intent(in) :: os_data
if (verify (workspace, ALLOWED_IN_DIRNAME) == 0) then
call msg_message ("Compile: preparing workspace directory '" &
// char (workspace) // "'")
call os_system_call ("mkdir -p '" // workspace // "'")
else
call msg_fatal ("compile: workspace name '" &
// char (workspace) // "' contains illegal characters")
end if
end subroutine setup_workspace
@ %def setup_workspace
@ Load the current library, just after compiling it.
<<Compilations: compilation item: TBP>>=
procedure :: load => compilation_item_load
<<Compilations: sub interfaces>>=
module subroutine compilation_item_load (comp, os_data)
class(compilation_item_t), intent(inout) :: comp
type(os_data_t), intent(in) :: os_data
end subroutine compilation_item_load
<<Compilations: procedures>>=
module subroutine compilation_item_load (comp, os_data)
class(compilation_item_t), intent(inout) :: comp
type(os_data_t), intent(in) :: os_data
if (associated (comp%lib)) then
call comp%lib%load (os_data, workspace=comp%workspace)
end if
end subroutine compilation_item_load
@ %def compilation_item_load
@ Message as a separate call:
<<Compilations: compilation item: TBP>>=
procedure :: success => compilation_item_success
<<Compilations: sub interfaces>>=
module subroutine compilation_item_success (comp)
class(compilation_item_t), intent(in) :: comp
end subroutine compilation_item_success
<<Compilations: procedures>>=
module subroutine compilation_item_success (comp)
class(compilation_item_t), intent(in) :: comp
if (associated (comp%lib)) then
call msg_message ("Process library '" // char (comp%libname) &
// "': ... success.")
else
call msg_fatal ("Process library '" // char (comp%libname) &
// "': ... failure.")
end if
end subroutine compilation_item_success
@ %def compilation_item_success
@ %def compilation_item_failure
@
\subsection{API for library compilation and loading}
This is a shorthand for compiling and loading a single library. The
[[compilation_item]] object is used only internally.
The [[global]] data set may actually be local to the caller. The
compilation affects the library specified by its name if it is on the
stack, but it does not reset the currently selected library.
<<Compilations: public>>=
public :: compile_library
<<Compilations: sub interfaces>>=
module subroutine compile_library (libname, global)
type(string_t), intent(in) :: libname
type(rt_data_t), intent(inout), target :: global
end subroutine compile_library
<<Compilations: procedures>>=
module subroutine compile_library (libname, global)
type(string_t), intent(in) :: libname
type(rt_data_t), intent(inout), target :: global
type(compilation_item_t) :: comp
logical :: force, recompile
force = &
global%var_list%get_lval (var_str ("?rebuild_library"))
recompile = &
global%var_list%get_lval (var_str ("?recompile_library"))
if (associated (global%model)) then
call comp%init (libname, global%prclib_stack, global%var_list)
call comp%compile (global%model, global%os_data, force, recompile)
if (signal_is_pending ()) return
call comp%load (global%os_data)
if (signal_is_pending ()) return
else
call msg_fatal ("Process library compilation: " &
// " model is undefined.")
end if
call comp%success ()
end subroutine compile_library
@ %def compile_library
@
\subsection{Compiling static executable}
This object handles the creation of a static executable which should
contain a set of static process libraries.
<<Compilations: public>>=
public :: compilation_t
<<Compilations: types>>=
type :: compilation_t
private
type(string_t) :: exe_name
type(string_t), dimension(:), allocatable :: lib_name
contains
<<Compilations: compilation: TBP>>
end type compilation_t
@ %def compilation_t
@ Output.
<<Compilations: compilation: TBP>>=
procedure :: write => compilation_write
<<Compilations: sub interfaces>>=
module subroutine compilation_write (object, unit)
class(compilation_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine compilation_write
<<Compilations: procedures>>=
module subroutine compilation_write (object, unit)
class(compilation_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
write (u, "(1x,A)") "Compilation object:"
write (u, "(3x,3A)") "executable = '", &
char (object%exe_name), "'"
write (u, "(3x,A)", advance="no") "process libraries ="
do i = 1, size (object%lib_name)
write (u, "(1x,3A)", advance="no") "'", char (object%lib_name(i)), "'"
end do
write (u, *)
end subroutine compilation_write
@ %def compilation_write
@ Initialize: we know the names of the executable and of the libraries.
Optionally, we may provide a workspace directory.
<<Compilations: compilation: TBP>>=
procedure :: init => compilation_init
<<Compilations: sub interfaces>>=
module subroutine compilation_init (compilation, exe_name, lib_name)
class(compilation_t), intent(out) :: compilation
type(string_t), intent(in) :: exe_name
type(string_t), dimension(:), intent(in) :: lib_name
end subroutine compilation_init
<<Compilations: procedures>>=
module subroutine compilation_init (compilation, exe_name, lib_name)
class(compilation_t), intent(out) :: compilation
type(string_t), intent(in) :: exe_name
type(string_t), dimension(:), intent(in) :: lib_name
compilation%exe_name = exe_name
allocate (compilation%lib_name (size (lib_name)))
compilation%lib_name = lib_name
end subroutine compilation_init
@ %def compilation_init
@ Write the dispatcher subroutine for the compiled libraries. Also
write a subroutine which returns the names of the compiled libraries.
<<Compilations: compilation: TBP>>=
procedure :: write_dispatcher => compilation_write_dispatcher
<<Compilations: sub interfaces>>=
module subroutine compilation_write_dispatcher (compilation)
class(compilation_t), intent(in) :: compilation
end subroutine compilation_write_dispatcher
<<Compilations: procedures>>=
module subroutine compilation_write_dispatcher (compilation)
class(compilation_t), intent(in) :: compilation
type(string_t) :: file
integer :: u, i
file = compilation%exe_name // "_prclib_dispatcher.f90"
call msg_message ("Static executable '" // char (compilation%exe_name) &
// "': writing library dispatcher")
u = free_unit ()
open (u, file = char (file), status="replace", action="write")
write (u, "(3A)") "! Whizard: process libraries for executable '", &
char (compilation%exe_name), "'"
write (u, "(A)") "! Automatically generated file, do not edit"
write (u, "(A)") "subroutine dispatch_prclib_static " // &
"(driver, basename, modellibs_ldflags)"
write (u, "(A)") " use iso_varying_string, string_t => varying_string"
write (u, "(A)") " use prclib_interfaces"
do i = 1, size (compilation%lib_name)
associate (lib_name => compilation%lib_name(i))
write (u, "(A)") " use " // char (lib_name) // "_driver"
end associate
end do
write (u, "(A)") " implicit none"
write (u, "(A)") " class(prclib_driver_t), intent(inout), allocatable &
&:: driver"
write (u, "(A)") " type(string_t), intent(in) :: basename"
write (u, "(A)") " logical, intent(in), optional :: " // &
"modellibs_ldflags"
write (u, "(A)") " select case (char (basename))"
do i = 1, size (compilation%lib_name)
associate (lib_name => compilation%lib_name(i))
write (u, "(3A)") " case ('", char (lib_name), "')"
write (u, "(3A)") " allocate (", char (lib_name), "_driver_t &
&:: driver)"
end associate
end do
write (u, "(A)") " end select"
write (u, "(A)") "end subroutine dispatch_prclib_static"
write (u, *)
write (u, "(A)") "subroutine get_prclib_static (libname)"
write (u, "(A)") " use iso_varying_string, string_t => varying_string"
write (u, "(A)") " implicit none"
write (u, "(A)") " type(string_t), dimension(:), intent(inout), &
&allocatable :: libname"
write (u, "(A,I0,A)") " allocate (libname (", &
size (compilation%lib_name), "))"
do i = 1, size (compilation%lib_name)
associate (lib_name => compilation%lib_name(i))
write (u, "(A,I0,A,A,A)") " libname(", i, ") = '", &
char (lib_name), "'"
end associate
end do
write (u, "(A)") "end subroutine get_prclib_static"
close (u)
end subroutine compilation_write_dispatcher
@ %def compilation_write_dispatcher
@ Write the Makefile subroutine for the compiled libraries.
<<Compilations: compilation: TBP>>=
procedure :: write_makefile => compilation_write_makefile
<<Compilations: sub interfaces>>=
module subroutine compilation_write_makefile &
(compilation, os_data, ext_libtag, verbose, overwrite_os)
class(compilation_t), intent(in) :: compilation
type(os_data_t), intent(in) :: os_data
logical, intent(in) :: verbose
logical, intent(in), optional :: overwrite_os
type(string_t), intent(in), optional :: ext_libtag
end subroutine compilation_write_makefile
<<Compilations: procedures>>=
module subroutine compilation_write_makefile &
(compilation, os_data, ext_libtag, verbose, overwrite_os)
class(compilation_t), intent(in) :: compilation
type(os_data_t), intent(in) :: os_data
logical, intent(in) :: verbose
logical, intent(in), optional :: overwrite_os
type(string_t), intent(in), optional :: ext_libtag
logical :: overwrite
type(string_t) :: file, ext_tag
integer :: u, i
overwrite = .false.
if (present (overwrite_os)) overwrite = overwrite_os
if (present (ext_libtag)) then
ext_tag = ext_libtag
else
ext_tag = ""
end if
file = compilation%exe_name // ".makefile"
call msg_message ("Static executable '" // char (compilation%exe_name) &
// "': writing makefile")
u = free_unit ()
open (u, file = char (file), status="replace", action="write")
write (u, "(3A)") "# WHIZARD: Makefile for executable '", &
char (compilation%exe_name), "'"
write (u, "(A)") "# Automatically generated file, do not edit"
write (u, "(A)") ""
write (u, "(A)") "# Executable name"
write (u, "(A)") "EXE = " // char (compilation%exe_name)
write (u, "(A)") ""
write (u, "(A)") "# Compiler"
write (u, "(A)") "FC = " // char (os_data%fc)
write (u, "(A)") "CXX = " // char (os_data%cxx)
write (u, "(A)") ""
write (u, "(A)") "# Included libraries"
write (u, "(A)") "FCINCL = " // char (os_data%whizard_includes)
write (u, "(A)") ""
write (u, "(A)") "# Compiler flags"
write (u, "(A)") "FCFLAGS = " // char (os_data%fcflags)
write (u, "(A)") "FCLIBS = " // char (os_data%fclibs)
write (u, "(A)") "CXXFLAGS = " // char (os_data%cxxflags)
write (u, "(A)") "CXXLIBSS = " // char (os_data%cxxlibs)
write (u, "(A)") "LDFLAGS = " // char (os_data%ldflags)
write (u, "(A)") "LDFLAGS_STATIC = " // char (os_data%ldflags_static)
write (u, "(A)") "LDFLAGS_HEPMC = " // char (os_data%ldflags_hepmc)
write (u, "(A)") "LDFLAGS_LCIO = " // char (os_data%ldflags_lcio)
write (u, "(A)") "LDFLAGS_HOPPET = " // char (os_data%ldflags_hoppet)
write (u, "(A)") "LDFLAGS_LOOPTOOLS = " // char (os_data%ldflags_looptools)
write (u, "(A)") "LDWHIZARD = " // char (os_data%whizard_ldflags)
write (u, "(A)") ""
write (u, "(A)") "# Libtool"
write (u, "(A)") "LIBTOOL = " // char (os_data%whizard_libtool)
if (verbose) then
write (u, "(A)") "FCOMPILE = $(LIBTOOL) --tag=FC --mode=compile"
if (OS_IS_DARWIN .and. .not. overwrite) then
write (u, "(A)") "LINK = $(LIBTOOL) --tag=CXX --mode=link"
else
write (u, "(A)") "LINK = $(LIBTOOL) --tag=FC --mode=link"
end if
else
write (u, "(A)") "FCOMPILE = @$(LIBTOOL) --silent --tag=FC --mode=compile"
if (OS_IS_DARWIN .and. .not. overwrite) then
write (u, "(A)") "LINK = @$(LIBTOOL) --silent --tag=CXX --mode=link"
else
write (u, "(A)") "LINK = @$(LIBTOOL) --silent --tag=FC --mode=link"
end if
end if
write (u, "(A)") ""
write (u, "(A)") "# Compile commands (default)"
write (u, "(A)") "LTFCOMPILE = $(FCOMPILE) $(FC) -c $(FCINCL) $(FCFLAGS)"
write (u, "(A)") ""
write (u, "(A)") "# Default target"
write (u, "(A)") "all: link"
write (u, "(A)") ""
write (u, "(A)") "# Libraries"
do i = 1, size (compilation%lib_name)
associate (lib_name => compilation%lib_name(i))
write (u, "(A)") "LIBRARIES += " // char (lib_name) // ".la"
write (u, "(A)") char (lib_name) // ".la:"
write (u, "(A)") TAB // "$(MAKE) -f " // char (lib_name) // ".makefile"
end associate
end do
write (u, "(A)") ""
write (u, "(A)") "# Library dispatcher"
write (u, "(A)") "DISP = $(EXE)_prclib_dispatcher"
write (u, "(A)") "$(DISP).lo: $(DISP).f90 $(LIBRARIES)"
if (.not. verbose) then
write (u, "(A)") TAB // '@echo " FC " $@'
end if
write (u, "(A)") TAB // "$(LTFCOMPILE) $<"
write (u, "(A)") ""
write (u, "(A)") "# Executable"
write (u, "(A)") "$(EXE): $(DISP).lo $(LIBRARIES)"
if (.not. verbose) then
if (OS_IS_DARWIN .and. .not. overwrite) then
write (u, "(A)") TAB // '@echo " CXXLD " $@'
else
write (u, "(A)") TAB // '@echo " FCLD " $@'
end if
end if
if (OS_IS_DARWIN .and. .not. overwrite) then
write (u, "(A)") TAB // "$(LINK) $(CXX) -static $(CXXFLAGS) \"
else
write (u, "(A)") TAB // "$(LINK) $(FC) -static $(FCFLAGS) \"
end if
write (u, "(A)") TAB // " $(LDWHIZARD) $(LDFLAGS) \"
write (u, "(A)") TAB // " -o $(EXE) $^ \"
write (u, "(A)") TAB // " $(LDFLAGS_HEPMC) $(LDFLAGS_LCIO) $(LDFLAGS_HOPPET) \"
if (OS_IS_DARWIN .and. .not. overwrite) then
write (u, "(A)") TAB // " $(LDFLAGS_LOOPTOOLS) $(LDFLAGS_STATIC) \"
write (u, "(A)") TAB // " $(CXXLIBS) $(FCLIBS)" // char (ext_tag)
else
write (u, "(A)") TAB // " $(LDFLAGS_LOOPTOOLS) $(LDFLAGS_STATIC)" // char (ext_tag)
end if
write (u, "(A)") ""
write (u, "(A)") "# Main targets"
write (u, "(A)") "link: compile $(EXE)"
write (u, "(A)") "compile: $(LIBRARIES) $(DISP).lo"
write (u, "(A)") ".PHONY: link compile"
write (u, "(A)") ""
write (u, "(A)") "# Cleanup targets"
write (u, "(A)") "clean-exe:"
write (u, "(A)") TAB // "rm -f $(EXE)"
write (u, "(A)") "clean-objects:"
write (u, "(A)") TAB // "rm -f $(DISP).lo"
write (u, "(A)") "clean-source:"
write (u, "(A)") TAB // "rm -f $(DISP).f90"
write (u, "(A)") "clean-makefile:"
write (u, "(A)") TAB // "rm -f $(EXE).makefile"
write (u, "(A)") ""
write (u, "(A)") "clean: clean-exe clean-objects clean-source"
write (u, "(A)") "distclean: clean clean-makefile"
write (u, "(A)") ".PHONY: clean distclean"
close (u)
end subroutine compilation_write_makefile
@ %def compilation_write_makefile
@ Compile the dispatcher source code.
<<Compilations: compilation: TBP>>=
procedure :: make_compile => compilation_make_compile
<<Compilations: sub interfaces>>=
module subroutine compilation_make_compile (compilation, os_data)
class(compilation_t), intent(in) :: compilation
type(os_data_t), intent(in) :: os_data
end subroutine compilation_make_compile
<<Compilations: procedures>>=
module subroutine compilation_make_compile (compilation, os_data)
class(compilation_t), intent(in) :: compilation
type(os_data_t), intent(in) :: os_data
call os_system_call ("make compile " // os_data%makeflags &
// " -f " // compilation%exe_name // ".makefile")
end subroutine compilation_make_compile
@ %def compilation_make_compile
@ Link the dispatcher together with all matrix-element code and the
\whizard\ and \oMega\ main libraries, to generate a static executable.
<<Compilations: compilation: TBP>>=
procedure :: make_link => compilation_make_link
<<Compilations: sub interfaces>>=
module subroutine compilation_make_link (compilation, os_data)
class(compilation_t), intent(in) :: compilation
type(os_data_t), intent(in) :: os_data
end subroutine compilation_make_link
<<Compilations: procedures>>=
module subroutine compilation_make_link (compilation, os_data)
class(compilation_t), intent(in) :: compilation
type(os_data_t), intent(in) :: os_data
call os_system_call ("make link " // os_data%makeflags &
// " -f " // compilation%exe_name // ".makefile")
end subroutine compilation_make_link
@ %def compilation_make_link
@ Cleanup.
<<Compilations: compilation: TBP>>=
procedure :: make_clean_exe => compilation_make_clean_exe
<<Compilations: sub interfaces>>=
module subroutine compilation_make_clean_exe (compilation, os_data)
class(compilation_t), intent(in) :: compilation
type(os_data_t), intent(in) :: os_data
end subroutine compilation_make_clean_exe
<<Compilations: procedures>>=
module subroutine compilation_make_clean_exe (compilation, os_data)
class(compilation_t), intent(in) :: compilation
type(os_data_t), intent(in) :: os_data
call os_system_call ("make clean-exe " // os_data%makeflags &
// " -f " // compilation%exe_name // ".makefile")
end subroutine compilation_make_clean_exe
@ %def compilation_make_clean_exe
@
\subsection{API for executable compilation}
This is a shorthand for compiling and loading an executable, including
the enclosed libraries. The [[compilation]] object is used only internally.
The [[global]] data set may actually be local to the caller. The
compilation affects the library specified by its name if it is on the
stack, but it does not reset the currently selected library.
<<Compilations: public>>=
public :: compile_executable
<<Compilations: sub interfaces>>=
module subroutine compile_executable (exename, libname, global)
type(string_t), intent(in) :: exename
type(string_t), dimension(:), intent(in) :: libname
type(rt_data_t), intent(inout), target :: global
end subroutine compile_executable
<<Compilations: procedures>>=
module subroutine compile_executable (exename, libname, global)
type(string_t), intent(in) :: exename
type(string_t), dimension(:), intent(in) :: libname
type(rt_data_t), intent(inout), target :: global
type(compilation_t) :: compilation
type(compilation_item_t) :: item
type(string_t) :: ext_libtag
logical :: force, recompile, verbose
integer :: i
ext_libtag = ""
force = &
global%var_list%get_lval (var_str ("?rebuild_library"))
recompile = &
global%var_list%get_lval (var_str ("?recompile_library"))
verbose = &
global%var_list%get_lval (var_str ("?me_verbose"))
call compilation%init (exename, [libname])
if (signal_is_pending ()) return
call compilation%write_dispatcher ()
if (signal_is_pending ()) return
do i = 1, size (libname)
call item%init (libname(i), global%prclib_stack, global%var_list)
call item%compile (global%model, global%os_data, &
force=force, recompile=recompile)
ext_libtag = "" // item%lib%get_static_modelname (global%os_data)
if (signal_is_pending ()) return
call item%success ()
end do
call compilation%write_makefile &
(global%os_data, ext_libtag=ext_libtag, verbose=verbose)
if (signal_is_pending ()) return
call compilation%make_compile (global%os_data)
if (signal_is_pending ()) return
call compilation%make_link (global%os_data)
end subroutine compile_executable
@ %def compile_executable
@
\subsection{Unit Tests}
Test module, followed by the stand-alone unit-test procedures.
<<[[compilations_ut.f90]]>>=
<<File header>>
module compilations_ut
use unit_tests
use compilations_uti
<<Standard module head>>
<<Compilations: public test>>
contains
<<Compilations: test driver>>
end module compilations_ut
@ %def compilations_ut
@
<<[[compilations_uti.f90]]>>=
<<File header>>
module compilations_uti
<<Use strings>>
use io_units
use models
use rt_data
use process_configurations_ut, only: prepare_test_library
use compilations
<<Standard module head>>
<<Compilations: test declarations>>
contains
<<Compilations: tests>>
end module compilations_uti
@ %def compilations_uti
@ API: driver for the unit tests below.
<<Compilations: public test>>=
public :: compilations_test
<<Compilations: test driver>>=
subroutine compilations_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Compilations: execute tests>>
end subroutine compilations_test
@ %def compilations_test
@
\subsubsection{Intrinsic Matrix Element}
Compile an intrinsic test matrix element ([[prc_test]] type).
Note: In this and the following test, we reset the Fortran compiler and flag
variables immediately before they are printed, so the test is portable.
<<Compilations: execute tests>>=
call test (compilations_1, "compilations_1", &
"intrinsic test processes", &
u, results)
<<Compilations: test declarations>>=
public :: compilations_1
<<Compilations: tests>>=
subroutine compilations_1 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname
type(rt_data_t), target :: global
write (u, "(A)") "* Test output: compilations_1"
write (u, "(A)") "* Purpose: configure and compile test process"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
libname = "compilation_1"
procname = "prc_comp_1"
call prepare_test_library (global, libname, 1, [procname])
call compile_library (libname, global)
call global%write_libraries (u)
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: compilations_1"
end subroutine compilations_1
@ %def compilations_1
@
\subsubsection{External Matrix Element}
Compile an external test matrix element ([[omega]] type)
<<Compilations: execute tests>>=
call test (compilations_2, "compilations_2", &
"external process (omega)", &
u, results)
<<Compilations: test declarations>>=
public :: compilations_2
<<Compilations: tests>>=
subroutine compilations_2 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname
type(rt_data_t), target :: global
write (u, "(A)") "* Test output: compilations_2"
write (u, "(A)") "* Purpose: configure and compile test process"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
libname = "compilation_2"
procname = "prc_comp_2"
call prepare_test_library (global, libname, 2, [procname,procname])
call compile_library (libname, global)
call global%write_libraries (u, libpath = .false.)
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: compilations_2"
end subroutine compilations_2
@ %def compilations_2
@
\subsubsection{External Matrix Element}
Compile an external test matrix element ([[omega]] type) and
create driver files for a static executable.
<<Compilations: execute tests>>=
call test (compilations_3, "compilations_3", &
"static executable: driver", &
u, results)
<<Compilations: test declarations>>=
public :: compilations_3
<<Compilations: tests>>=
subroutine compilations_3 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname, exename
type(rt_data_t), target :: global
type(compilation_t) :: compilation
integer :: u_file
character(80) :: buffer
write (u, "(A)") "* Test output: compilations_3"
write (u, "(A)") "* Purpose: make static executable"
write (u, "(A)")
write (u, "(A)") "* Initialize library"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
libname = "compilations_3_lib"
procname = "prc_comp_3"
exename = "compilations_3"
call prepare_test_library (global, libname, 2, [procname,procname])
call compilation%init (exename, [libname])
call compilation%write (u)
write (u, "(A)")
write (u, "(A)") "* Write dispatcher"
write (u, "(A)")
call compilation%write_dispatcher ()
u_file = free_unit ()
open (u_file, file = char (exename) // "_prclib_dispatcher.f90", &
status = "old", action = "read")
do
read (u_file, "(A)", end = 1) buffer
write (u, "(A)") trim (buffer)
end do
1 close (u_file)
write (u, "(A)")
write (u, "(A)") "* Write Makefile"
write (u, "(A)")
associate (os_data => global%os_data)
os_data%fc = "fortran-compiler"
os_data%cxx = "c++-compiler"
os_data%whizard_includes = "my-includes"
os_data%fcflags = "my-fcflags"
os_data%fclibs = "my-fclibs"
os_data%cxxflags = "my-cxxflags"
os_data%cxxlibs = "my-cxxlibs"
os_data%ldflags = "my-ldflags"
os_data%ldflags_static = "my-ldflags-static"
os_data%ldflags_hepmc = "my-ldflags-hepmc"
os_data%ldflags_lcio = "my-ldflags-lcio"
os_data%ldflags_hoppet = "my-ldflags-hoppet"
os_data%ldflags_looptools = "my-ldflags-looptools"
os_data%whizard_ldflags = "my-ldwhizard"
os_data%whizard_libtool = "my-libtool"
end associate
call compilation%write_makefile &
(global%os_data, verbose = .true., overwrite_os = .true.)
open (u_file, file = char (exename) // ".makefile", &
status = "old", action = "read")
do
read (u_file, "(A)", end = 2) buffer
write (u, "(A)") trim (buffer)
end do
2 close (u_file)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: compilations_3"
end subroutine compilations_3
@ %def compilations_3
@
\subsection{Test static build}
The tests for building a static executable are separate, since they
should be skipped if the \whizard\ build itself has static libraries
disabled.
<<Compilations: public test>>=
public :: compilations_static_test
<<Compilations: test driver>>=
subroutine compilations_static_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Compilations: static tests>>
end subroutine compilations_static_test
@ %def compilations_static_test
@
\subsubsection{External Matrix Element}
Compile an external test matrix element ([[omega]] type) and
incorporate this in a new static WHIZARD executable.
<<Compilations: static tests>>=
call test (compilations_static_1, "compilations_static_1", &
"static executable: compilation", &
u, results)
<<Compilations: test declarations>>=
public :: compilations_static_1
<<Compilations: tests>>=
subroutine compilations_static_1 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname, exename
type(rt_data_t), target :: global
type(compilation_item_t) :: item
type(compilation_t) :: compilation
logical :: exist
write (u, "(A)") "* Test output: compilations_static_1"
write (u, "(A)") "* Purpose: make static executable"
write (u, "(A)")
write (u, "(A)") "* Initialize library"
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
libname = "compilations_static_1_lib"
procname = "prc_comp_stat_1"
exename = "compilations_static_1"
call prepare_test_library (global, libname, 2, [procname,procname])
call compilation%init (exename, [libname])
write (u, "(A)")
write (u, "(A)") "* Write dispatcher"
call compilation%write_dispatcher ()
write (u, "(A)")
write (u, "(A)") "* Write Makefile"
call compilation%write_makefile (global%os_data, verbose = .true.)
write (u, "(A)")
write (u, "(A)") "* Build libraries"
call item%init (libname, global%prclib_stack, global%var_list)
call item%compile &
(global%model, global%os_data, force=.true., recompile=.false.)
call item%success ()
write (u, "(A)")
write (u, "(A)") "* Check executable (should be absent)"
write (u, "(A)")
call compilation%make_clean_exe (global%os_data)
inquire (file = char (exename), exist = exist)
write (u, "(A,A,L1)") char (exename), " exists = ", exist
write (u, "(A)")
write (u, "(A)") "* Build executable"
write (u, "(A)")
call compilation%make_compile (global%os_data)
call compilation%make_link (global%os_data)
write (u, "(A)") "* Check executable (should be present)"
write (u, "(A)")
inquire (file = char (exename), exist = exist)
write (u, "(A,A,L1)") char (exename), " exists = ", exist
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call compilation%make_clean_exe (global%os_data)
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: compilations_static_1"
end subroutine compilations_static_1
@ %def compilations_static_1
@
\subsubsection{External Matrix Element}
Compile an external test matrix element ([[omega]] type) and
incorporate this in a new static WHIZARD executable. In this version,
we use the wrapper [[compile_executable]] procedure.
<<Compilations: static tests>>=
call test (compilations_static_2, "compilations_static_2", &
"static executable: shortcut", &
u, results)
<<Compilations: test declarations>>=
public :: compilations_static_2
<<Compilations: tests>>=
subroutine compilations_static_2 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname, exename
type(rt_data_t), target :: global
logical :: exist
integer :: u_file
write (u, "(A)") "* Test output: compilations_static_2"
write (u, "(A)") "* Purpose: make static executable"
write (u, "(A)")
write (u, "(A)") "* Initialize library and compile"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
libname = "compilations_static_2_lib"
procname = "prc_comp_stat_2"
exename = "compilations_static_2"
call prepare_test_library (global, libname, 2, [procname,procname])
call compile_executable (exename, [libname], global)
write (u, "(A)") "* Check executable (should be present)"
write (u, "(A)")
inquire (file = char (exename), exist = exist)
write (u, "(A,A,L1)") char (exename), " exists = ", exist
write (u, "(A)")
write (u, "(A)") "* Cleanup"
u_file = free_unit ()
open (u_file, file = char (exename), status = "old", action = "write")
close (u_file, status = "delete")
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: compilations_static_2"
end subroutine compilations_static_2
@ %def compilations_static_2
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Integration}
This module manages phase space setup, matrix-element evaluation and
integration, as far as it is not done by lower-level routines, in particular
in the [[processes]] module.
<<[[integrations.f90]]>>=
<<File header>>
module integrations
<<Use kinds>>
<<Use strings>>
<<Use debug>>
use diagnostics
use prc_core
use process
use instances
use process_stacks
use iterations
use rt_data
use nlo_data
<<Standard module head>>
<<Integrations: public>>
<<Integrations: types>>
interface
<<Integrations: sub interfaces>>
end interface
contains
<<Integrations: main procedures>>
end module integrations
@ %def integrations
@
<<[[integrations_sub.f90]]>>=
<<File header>>
submodule (integrations) integrations_s
<<Use mpi f08>>
use io_units
use cputime
use os_interface
use physics_defs
use model_data
use pdg_arrays
use variables, only: var_list_t
use eval_trees
use sf_mappings
use sf_base
use phs_base
use models
use dispatch_me_methods, only: dispatch_core
use dispatch_beams, only: dispatch_qcd, sf_prop_t, dispatch_sf_config
use dispatch_phase_space, only: dispatch_sf_channels
use dispatch_phase_space, only: dispatch_phs
use dispatch_mci, only: dispatch_mci_setup, setup_grid_path
use dispatch_transforms, only: dispatch_evt_shower_hook
use compilations, only: compile_library
implicit none
contains
<<Integrations: procedures>>
end submodule integrations_s
@ %def integrations_s
@
\subsection{The integration type}
This type holds all relevant data, the integration methods operates on this.
In contrast to the [[simulation_t]] introduced later, the [[integration_t]]
applies to a single process.
<<Integrations: public>>=
public :: integration_t
<<Integrations: types>>=
type :: integration_t
private
type(string_t) :: process_id
type(string_t) :: run_id
type(process_t), pointer :: process => null ()
logical :: rebuild_phs = .false.
logical :: ignore_phs_mismatch = .false.
logical :: phs_only = .false.
logical :: process_has_me = .true.
integer :: n_calls_test = 0
logical :: vis_history = .true.
type(string_t) :: history_filename
type(string_t) :: log_filename
type(helicity_selection_t) :: helicity_selection
logical :: use_color_factors = .false.
logical :: has_beam_pol = .false.
logical :: combined_integration = .false.
type(iteration_multipliers_t) :: iteration_multipliers
type(nlo_settings_t) :: nlo_settings
contains
<<Integrations: integration: TBP>>
end type integration_t
@ %def integration_t
@
@
\subsection{Initialization}
Initialization, first part: Create a process entry.
Push it on the stack if the [[global]] environment is supplied.
Gfortran7/8/9 bug, has to remain in the main module:
<<Integrations: integration: TBP>>=
procedure :: create_process => integration_create_process
<<Integrations: main procedures>>=
subroutine integration_create_process (intg, process_id, global)
class(integration_t), intent(out) :: intg
type(rt_data_t), intent(inout), optional, target :: global
type(string_t), intent(in) :: process_id
type(process_entry_t), pointer :: process_entry
if (debug_on) call msg_debug (D_CORE, "integration_create_process")
intg%process_id = process_id
if (present (global)) then
allocate (process_entry)
intg%process => process_entry%process_t
call global%process_stack%push (process_entry)
else
allocate (process_t :: intg%process)
end if
end subroutine integration_create_process
@ %def integration_create_process
@ Initialization, second part: Initialize the process object, using the local
environment. We allocate a RNG factory and a QCD object.
We also fetch a pointer to the model that the process uses. The
process initializer will create a snapshot of that model.
This procedure
does not modify the [[local]] stack directly. The intent(inout) attribute for
the [[local]] data set is due to the random generator seed which may be
incremented during initialization.
NOTE: Changes to model parameters within the current context are respected
only if the process model coincides with the current model. This is the usual
case. If not, we read
the model from the global model library, which has default parameters. To
become more flexible, we should implement a local model library which records
local changes to currently inactive models.
<<Integrations: integration: TBP>>=
procedure :: init_process => integration_init_process
<<Integrations: sub interfaces>>=
module subroutine integration_init_process (intg, local)
class(integration_t), intent(inout) :: intg
type(rt_data_t), intent(inout), target :: local
end subroutine integration_init_process
<<Integrations: procedures>>=
module subroutine integration_init_process (intg, local)
class(integration_t), intent(inout) :: intg
type(rt_data_t), intent(inout), target :: local
type(string_t) :: model_name
type(model_t), pointer :: model
class(model_data_t), pointer :: model_instance
type(var_list_t), pointer :: var_list
if (debug_on) call msg_debug (D_CORE, "integration_init_process")
if (.not. local%prclib%contains (intg%process_id)) then
call msg_fatal ("Process '" // char (intg%process_id) // "' not found" &
// " in library '" // char (local%prclib%get_name ()) // "'")
return
end if
model_name = local%prclib%get_model_name (intg%process_id)
if (local%get_sval (var_str ("$model_name")) == model_name) then
model => local%model
else
model => local%model_list%get_model_ptr (model_name)
end if
var_list => local%get_var_list_ptr ()
call intg%process%init (intg%process_id, &
local%prclib, &
local%os_data, &
model, &
var_list, &
local%beam_structure)
intg%run_id = intg%process%get_run_id ()
end subroutine integration_init_process
@ %def integration_init_process
@ Initialization, third part: complete process configuration.
<<Integrations: integration: TBP>>=
procedure :: setup_process => integration_setup_process
<<Integrations: sub interfaces>>=
module subroutine integration_setup_process &
(intg, local, verbose, init_only)
class(integration_t), intent(inout) :: intg
type(rt_data_t), intent(inout), target :: local
logical, intent(in), optional :: verbose
logical, intent(in), optional :: init_only
end subroutine integration_setup_process
<<Integrations: procedures>>=
module subroutine integration_setup_process (intg, local, verbose, init_only)
class(integration_t), intent(inout) :: intg
type(rt_data_t), intent(inout), target :: local
logical, intent(in), optional :: verbose
logical, intent(in), optional :: init_only
type(var_list_t), pointer :: var_list
type(sf_config_t), dimension(:), allocatable :: sf_config
type(sf_prop_t) :: sf_prop
type(sf_channel_t), dimension(:), allocatable :: sf_channel
type(phs_channel_collection_t) :: phs_channel_collection
logical :: sf_trace
logical :: verb, initialize_only
type(string_t) :: sf_string
type(string_t) :: workspace
real(default) :: sqrts
verb = .true.; if (present (verbose)) verb = verbose
initialize_only = .false.
if (present (init_only)) initialize_only = init_only
call display_init_message (verb)
var_list => local%get_var_list_ptr ()
call setup_log_and_history ()
associate (process => intg%process)
call set_intg_parameters (process)
call process%setup_cores (dispatch_core, &
intg%helicity_selection, intg%use_color_factors, intg%has_beam_pol)
call process%init_phs_config ()
call process%init_components ()
call process%record_inactive_components ()
intg%process_has_me = process%has_matrix_element ()
if (.not. intg%process_has_me) then
call msg_warning ("Process '" &
// char (intg%process_id) // "': matrix element vanishes")
end if
call setup_beams ()
call setup_structure_functions ()
workspace = var_list%get_sval (var_str ("$integrate_workspace"))
if (workspace == "") then
call process%configure_phs &
(intg%rebuild_phs, &
intg%ignore_phs_mismatch, &
intg%combined_integration)
else
call setup_grid_path (workspace)
call process%configure_phs &
(intg%rebuild_phs, &
intg%ignore_phs_mismatch, &
intg%combined_integration, &
workspace)
end if
call process%complete_pcm_setup ()
call process%prepare_blha_cores ()
call process%create_blha_interface ()
call process%prepare_any_external_code ()
call process%setup_terms (with_beams = intg%has_beam_pol)
call process%check_masses ()
call process%optimize_nlo_singular_regions ()
if (verb) then
call process%write (screen = .true.)
call process%print_phs_startup_message ()
end if
if (intg%process_has_me) then
if (size (sf_config) > 0) then
call process%collect_channels (phs_channel_collection)
else if (.not. initialize_only &
.and. process%contains_trivial_component ()) then
call msg_fatal ("Integrate: 2 -> 1 process can't be handled &
&with fixed-energy beams")
end if
if (local%beam_structure%asymmetric ()) then
sqrts = process%get_sqrts ()
else
sqrts = local%get_sqrts ()
end if
call dispatch_sf_channels &
(sf_channel, sf_string, sf_prop, phs_channel_collection, &
local%var_list, sqrts, local%beam_structure)
if (allocated (sf_channel)) then
if (size (sf_channel) > 0) then
call process%set_sf_channel (sf_channel)
end if
end if
call phs_channel_collection%final ()
if (verb) call process%sf_startup_message (sf_string)
end if
call process%setup_mci (dispatch_mci_setup)
call setup_expressions ()
call process%compute_md5sum ()
end associate
contains
subroutine setup_log_and_history ()
if (intg%run_id /= "") then
intg%history_filename = intg%process_id // "." // intg%run_id &
// ".history"
intg%log_filename = intg%process_id // "." // intg%run_id // ".log"
else
intg%history_filename = intg%process_id // ".history"
intg%log_filename = intg%process_id // ".log"
end if
intg%vis_history = &
var_list%get_lval (var_str ("?vis_history"))
end subroutine setup_log_and_history
subroutine set_intg_parameters (process)
type(process_t), intent(in) :: process
intg%n_calls_test = &
var_list%get_ival (var_str ("n_calls_test"))
intg%combined_integration = &
var_list%get_lval (var_str ('?combined_nlo_integration')) &
.and. process%is_nlo_calculation ()
intg%use_color_factors = &
var_list%get_lval (var_str ("?read_color_factors"))
intg%has_beam_pol = &
local%beam_structure%has_polarized_beams ()
intg%helicity_selection = &
local%get_helicity_selection ()
intg%rebuild_phs = &
var_list%get_lval (var_str ("?rebuild_phase_space"))
intg%ignore_phs_mismatch = &
.not. var_list%get_lval (var_str ("?check_phs_file"))
intg%phs_only = &
var_list%get_lval (var_str ("?phs_only"))
end subroutine set_intg_parameters
subroutine display_init_message (verb)
logical, intent(in) :: verb
if (verb) then
call msg_message ("Initializing integration for process " &
// char (intg%process_id) // ":")
if (intg%run_id /= "") &
call msg_message ("Run ID = " // '"' // char (intg%run_id) // '"')
end if
end subroutine display_init_message
subroutine setup_beams ()
real(default) :: sqrts
logical :: decay_rest_frame
sqrts = local%get_sqrts ()
decay_rest_frame = &
var_list%get_lval (var_str ("?decay_rest_frame"))
if (intg%process_has_me) then
call intg%process%setup_beams_beam_structure &
(local%beam_structure, sqrts, decay_rest_frame)
end if
if (verb .and. intg%process_has_me) then
call intg%process%beams_startup_message &
(beam_structure = local%beam_structure)
end if
end subroutine setup_beams
subroutine setup_structure_functions ()
integer :: n_in
type(pdg_array_t), dimension(:,:), allocatable :: pdg_prc
type(string_t) :: sf_trace_file
if (intg%process_has_me) then
call intg%process%get_pdg_in (pdg_prc)
else
n_in = intg%process%get_n_in ()
allocate (pdg_prc (n_in, intg%process%get_n_components ()))
pdg_prc = 0
end if
call dispatch_sf_config (sf_config, sf_prop, local%beam_structure, &
local%get_var_list_ptr (), local%var_list, &
local%model, local%os_data, local%get_sqrts (), pdg_prc)
sf_trace = &
var_list%get_lval (var_str ("?sf_trace"))
sf_trace_file = &
var_list%get_sval (var_str ("$sf_trace_file"))
if (sf_trace) then
call intg%process%init_sf_chain (sf_config, sf_trace_file)
else
call intg%process%init_sf_chain (sf_config)
end if
end subroutine setup_structure_functions
subroutine setup_expressions ()
type(eval_tree_factory_t) :: expr_factory
if (associated (local%pn%cuts_lexpr)) then
if (verb) call msg_message ("Applying user-defined cuts.")
call expr_factory%init (local%pn%cuts_lexpr)
call intg%process%set_cuts (expr_factory)
else
if (verb) call msg_warning ("No cuts have been defined.")
end if
if (associated (local%pn%scale_expr)) then
if (verb) call msg_message ("Using user-defined general scale.")
call expr_factory%init (local%pn%scale_expr)
call intg%process%set_scale (expr_factory)
end if
if (associated (local%pn%fac_scale_expr)) then
if (verb) call msg_message ("Using user-defined factorization scale.")
call expr_factory%init (local%pn%fac_scale_expr)
call intg%process%set_fac_scale (expr_factory)
end if
if (associated (local%pn%ren_scale_expr)) then
if (verb) call msg_message ("Using user-defined renormalization scale.")
call expr_factory%init (local%pn%ren_scale_expr)
call intg%process%set_ren_scale (expr_factory)
end if
if (associated (local%pn%weight_expr)) then
if (verb) call msg_message ("Using user-defined reweighting factor.")
call expr_factory%init (local%pn%weight_expr)
call intg%process%set_weight (expr_factory)
end if
end subroutine setup_expressions
end subroutine integration_setup_process
@ %def integration_setup_process
@
\subsection{Integration}
Integrate: do the final integration. Here, we do a multi-iteration
integration. Again, we skip iterations that are already on file.
Record the results in the global variable list.
<<Integrations: integration: TBP>>=
procedure :: evaluate => integration_evaluate
<<Integrations: sub interfaces>>=
module subroutine integration_evaluate &
(intg, process_instance, i_mci, pass, it_list, pacify)
class(integration_t), intent(inout) :: intg
type(process_instance_t), intent(inout), target :: process_instance
integer, intent(in) :: i_mci
integer, intent(in) :: pass
type(iterations_list_t), intent(in) :: it_list
logical, intent(in), optional :: pacify
end subroutine integration_evaluate
<<Integrations: procedures>>=
module subroutine integration_evaluate &
(intg, process_instance, i_mci, pass, it_list, pacify)
class(integration_t), intent(inout) :: intg
type(process_instance_t), intent(inout), target :: process_instance
integer, intent(in) :: i_mci
integer, intent(in) :: pass
type(iterations_list_t), intent(in) :: it_list
logical, intent(in), optional :: pacify
integer :: n_calls, n_it
logical :: adapt_grids, adapt_weights, final
n_it = it_list%get_n_it (pass)
n_calls = it_list%get_n_calls (pass)
adapt_grids = it_list%adapt_grids (pass)
adapt_weights = it_list%adapt_weights (pass)
final = pass == it_list%get_n_pass ()
call process_instance%integrate ( &
i_mci, n_it, n_calls, adapt_grids, adapt_weights, &
final, pacify)
end subroutine integration_evaluate
@ %def integration_evaluate
@ In case the user has not provided a list of iterations, make a
reasonable default. This can depend on the process. The usual
approach is to define two distinct passes, one for adaptation and one
for integration.
<<Integrations: integration: TBP>>=
procedure :: make_iterations_list => integration_make_iterations_list
<<Integrations: sub interfaces>>=
module subroutine integration_make_iterations_list (intg, it_list)
class(integration_t), intent(in) :: intg
type(iterations_list_t), intent(out) :: it_list
end subroutine integration_make_iterations_list
<<Integrations: procedures>>=
module subroutine integration_make_iterations_list (intg, it_list)
class(integration_t), intent(in) :: intg
type(iterations_list_t), intent(out) :: it_list
integer :: pass, n_pass
integer, dimension(:), allocatable :: n_it, n_calls
logical, dimension(:), allocatable :: adapt_grids, adapt_weights
n_pass = intg%process%get_n_pass_default ()
allocate (n_it (n_pass), n_calls (n_pass))
allocate (adapt_grids (n_pass), adapt_weights (n_pass))
do pass = 1, n_pass
n_it(pass) = intg%process%get_n_it_default (pass)
n_calls(pass) = intg%process%get_n_calls_default (pass)
adapt_grids(pass) = intg%process%adapt_grids_default (pass)
adapt_weights(pass) = intg%process%adapt_weights_default (pass)
end do
call it_list%init (n_it, n_calls, &
adapt_grids = adapt_grids, adapt_weights = adapt_weights)
end subroutine integration_make_iterations_list
@ %def integration_make_iterations_list
@ In NLO calculations, the individual components might scale very differently
with the number of calls. This especially applies to the real-subtracted
component, which usually fluctuates more than the Born and virtual
component, making it a bottleneck of the calculation. Thus, the calculation
is throttled twice, first by the number of calls for the real component,
second by the number of surplus calls of computation-intense virtual
matrix elements. Therefore, we want to set a different number of calls
for each component, which is done by the subroutine [[integration_apply_call_multipliers]].
<<Integrations: integration: TBP>>=
procedure :: init_iteration_multipliers => &
integration_init_iteration_multipliers
<<Integrations: sub interfaces>>=
module subroutine integration_init_iteration_multipliers (intg, local)
class(integration_t), intent(inout) :: intg
type(rt_data_t), intent(in) :: local
end subroutine integration_init_iteration_multipliers
<<Integrations: procedures>>=
module subroutine integration_init_iteration_multipliers (intg, local)
class(integration_t), intent(inout) :: intg
type(rt_data_t), intent(in) :: local
integer :: n_pass, pass
type(iterations_list_t) :: it_list
n_pass = local%it_list%get_n_pass ()
if (n_pass == 0) then
call intg%make_iterations_list (it_list)
n_pass = it_list%get_n_pass ()
end if
associate (it_multipliers => intg%iteration_multipliers)
allocate (it_multipliers%n_calls0 (n_pass))
do pass = 1, n_pass
it_multipliers%n_calls0(pass) = local%it_list%get_n_calls (pass)
end do
it_multipliers%mult_real = local%var_list%get_rval &
(var_str ("mult_call_real"))
it_multipliers%mult_virt = local%var_list%get_rval &
(var_str ("mult_call_virt"))
it_multipliers%mult_dglap = local%var_list%get_rval &
(var_str ("mult_call_dglap"))
end associate
end subroutine integration_init_iteration_multipliers
@ %def integration_init_iteration_multipliers
@
<<Integrations: integration: TBP>>=
procedure :: apply_call_multipliers => integration_apply_call_multipliers
<<Integrations: sub interfaces>>=
module subroutine integration_apply_call_multipliers &
(intg, n_pass, i_component, it_list)
class(integration_t), intent(in) :: intg
integer, intent(in) :: n_pass, i_component
type(iterations_list_t), intent(inout) :: it_list
end subroutine integration_apply_call_multipliers
<<Integrations: procedures>>=
module subroutine integration_apply_call_multipliers &
(intg, n_pass, i_component, it_list)
class(integration_t), intent(in) :: intg
integer, intent(in) :: n_pass, i_component
type(iterations_list_t), intent(inout) :: it_list
integer :: nlo_type
integer :: n_calls0, n_calls
integer :: pass
real(default) :: multiplier
nlo_type = intg%process%get_component_nlo_type (i_component)
do pass = 1, n_pass
associate (multipliers => intg%iteration_multipliers)
select case (nlo_type)
case (NLO_REAL)
multiplier = multipliers%mult_real
case (NLO_VIRTUAL)
multiplier = multipliers%mult_virt
case (NLO_DGLAP)
multiplier = multipliers%mult_dglap
case default
return
end select
end associate
if (n_pass <= size (intg%iteration_multipliers%n_calls0)) then
n_calls0 = intg%iteration_multipliers%n_calls0 (pass)
n_calls = floor (multiplier * n_calls0)
call it_list%set_n_calls (pass, n_calls)
end if
end do
end subroutine integration_apply_call_multipliers
@ %def integration_apply_call_multipliers
@
\subsection{API for integration objects}
This initializer does everything except assigning cuts/scale/weight
expressions.
<<Integrations: integration: TBP>>=
procedure :: init => integration_init
<<Integrations: sub interfaces>>=
module subroutine integration_init &
(intg, process_id, local, global, local_stack, init_only)
class(integration_t), intent(out) :: intg
type(string_t), intent(in) :: process_id
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
logical, intent(in), optional :: init_only
logical, intent(in), optional :: local_stack
end subroutine integration_init
<<Integrations: procedures>>=
module subroutine integration_init &
(intg, process_id, local, global, local_stack, init_only)
class(integration_t), intent(out) :: intg
type(string_t), intent(in) :: process_id
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
logical, intent(in), optional :: init_only
logical, intent(in), optional :: local_stack
logical :: use_local
use_local = .false.; if (present (local_stack)) use_local = local_stack
if (present (global)) then
call intg%create_process (process_id, global)
else if (use_local) then
call intg%create_process (process_id, local)
else
call intg%create_process (process_id)
end if
call intg%init_process (local)
call intg%setup_process (local, init_only = init_only)
call intg%init_iteration_multipliers (local)
end subroutine integration_init
@ %def integration_init
@ Do the integration for a single process, both warmup and final evaluation.
The [[eff_reset]] flag is to suppress numerical noise in the graphical output
of the integration history.
<<Integrations: integration: TBP>>=
procedure :: integrate => integration_integrate
<<Integrations: sub interfaces>>=
module subroutine integration_integrate (intg, local, eff_reset)
class(integration_t), intent(inout) :: intg
type(rt_data_t), intent(in), target :: local
logical, intent(in), optional :: eff_reset
end subroutine integration_integrate
<<Integrations: procedures>>=
module subroutine integration_integrate (intg, local, eff_reset)
class(integration_t), intent(inout) :: intg
type(rt_data_t), intent(in), target :: local
logical, intent(in), optional :: eff_reset
type(string_t) :: log_filename
type(var_list_t), pointer :: var_list
type(process_instance_t), allocatable, target :: process_instance
type(iterations_list_t) :: it_list
logical :: pacify
integer :: pass, i_mci, n_mci, n_pass
integer :: i_component
integer :: nlo_type
logical :: display_summed
logical :: nlo_active
type(string_t) :: component_output
allocate (process_instance)
call process_instance%init (intg%process)
var_list => intg%process%get_var_list_ptr ()
call openmp_set_num_threads_verbose &
(var_list%get_ival (var_str ("openmp_num_threads")), &
var_list%get_lval (var_str ("?openmp_logging")))
pacify = var_list%get_lval (var_str ("?pacify"))
display_summed = .true.
n_mci = intg%process%get_n_mci ()
if (n_mci == 1) then
write (msg_buffer, "(A,A,A)") &
"Starting integration for process '", &
char (intg%process%get_id ()), "'"
call msg_message ()
end if
call setup_hooks ()
nlo_active = any (intg%process%get_component_nlo_type &
([(i_mci, i_mci = 1, n_mci)]) /= BORN)
do i_mci = 1, n_mci
i_component = intg%process%get_master_component (i_mci)
nlo_type = intg%process%get_component_nlo_type (i_component)
if (intg%process%component_can_be_integrated (i_component)) then
if (n_mci > 1) then
if (nlo_active) then
if (intg%combined_integration .and. nlo_type == BORN) then
component_output = var_str ("Combined")
else
component_output = component_status (nlo_type)
end if
write (msg_buffer, "(A,A,A,A,A)") &
"Starting integration for process '", &
char (intg%process%get_id ()), "' part '", &
char (component_output), "'"
else
write (msg_buffer, "(A,A,A,I0)") &
"Starting integration for process '", &
char (intg%process%get_id ()), "' part ", i_mci
end if
call msg_message ()
end if
n_pass = local%it_list%get_n_pass ()
if (n_pass == 0) then
call msg_message ("Integrate: iterations not specified, &
&using default")
call intg%make_iterations_list (it_list)
n_pass = it_list%get_n_pass ()
else
it_list = local%it_list
end if
call intg%apply_call_multipliers (n_pass, i_mci, it_list)
call msg_message ("Integrate: " // char (it_list%to_string ()))
do pass = 1, n_pass
call intg%evaluate (process_instance, i_mci, pass, it_list, pacify)
if (signal_is_pending ()) return
end do
call intg%process%final_integration (i_mci)
if (intg%vis_history) then
call intg%process%display_integration_history &
(i_mci, intg%history_filename, local%os_data, eff_reset)
end if
if (local%logfile == intg%log_filename) then
if (intg%run_id /= "") then
log_filename = intg%process_id // "." // intg%run_id // &
".var.log"
else
log_filename = intg%process_id // ".var.log"
end if
call msg_message ("Name clash for global logfile and process log: ", &
arr =[var_str ("| Renaming log file from ") // local%logfile, &
var_str ("| to ") // log_filename // var_str (" .")])
else
log_filename = intg%log_filename
end if
call intg%process%write_logfile (i_mci, log_filename)
end if
end do
if (n_mci > 1 .and. display_summed) then
call msg_message ("Integrate: sum of all components")
call intg%process%display_summed_results (pacify)
end if
call process_instance%final ()
deallocate (process_instance)
contains
subroutine setup_hooks ()
class(process_instance_hook_t), pointer :: hook
call dispatch_evt_shower_hook (hook, var_list, process_instance, &
local%beam_structure, intg%process%get_pdf_set())
if (associated (hook)) then
call process_instance%append_after_hook (hook)
end if
end subroutine setup_hooks
end subroutine integration_integrate
@ %def integration_integrate
@ Do a dummy integration for a process which could not be initialized (e.g.,
has no matrix element). The result is zero.
<<Integrations: integration: TBP>>=
procedure :: integrate_dummy => integration_integrate_dummy
<<Integrations: sub interfaces>>=
module subroutine integration_integrate_dummy (intg)
class(integration_t), intent(inout) :: intg
end subroutine integration_integrate_dummy
<<Integrations: procedures>>=
module subroutine integration_integrate_dummy (intg)
class(integration_t), intent(inout) :: intg
call intg%process%integrate_dummy ()
end subroutine integration_integrate_dummy
@ %def integration_integrate_dummy
@ Just sample the matrix element under realistic conditions (but no
cuts); throw away the results.
<<Integrations: integration: TBP>>=
procedure :: sampler_test => integration_sampler_test
<<Integrations: sub interfaces>>=
module subroutine integration_sampler_test (intg)
class(integration_t), intent(inout) :: intg
end subroutine integration_sampler_test
<<Integrations: procedures>>=
module subroutine integration_sampler_test (intg)
class(integration_t), intent(inout) :: intg
type(process_instance_t), allocatable, target :: process_instance
integer :: n_mci, i_mci
type(timer_t) :: timer_mci, timer_tot
real(default) :: t_mci, t_tot
allocate (process_instance)
call process_instance%init (intg%process)
n_mci = intg%process%get_n_mci ()
if (n_mci == 1) then
write (msg_buffer, "(A,A,A)") &
"Test: probing process '", &
char (intg%process%get_id ()), "'"
call msg_message ()
end if
call timer_tot%start ()
do i_mci = 1, n_mci
if (n_mci > 1) then
write (msg_buffer, "(A,A,A,I0)") &
"Test: probing process '", &
char (intg%process%get_id ()), "' part ", i_mci
call msg_message ()
end if
call timer_mci%start ()
call process_instance%sampler_test (i_mci, intg%n_calls_test)
call timer_mci%stop ()
t_mci = timer_mci
write (msg_buffer, "(A,ES12.5)") "Test: " &
// "time in seconds (wallclock): ", t_mci
call msg_message ()
end do
call timer_tot%stop ()
t_tot = timer_tot
if (n_mci > 1) then
write (msg_buffer, "(A,ES12.5)") "Test: " &
// "total time (wallclock): ", t_tot
call msg_message ()
end if
call process_instance%final ()
end subroutine integration_sampler_test
@ %def integration_sampler_test
@ Return the process pointer (needed by simulate):
<<Integrations: integration: TBP>>=
procedure :: get_process_ptr => integration_get_process_ptr
<<Integrations: sub interfaces>>=
module function integration_get_process_ptr (intg) result (ptr)
class(integration_t), intent(in) :: intg
type(process_t), pointer :: ptr
end function integration_get_process_ptr
<<Integrations: procedures>>=
module function integration_get_process_ptr (intg) result (ptr)
class(integration_t), intent(in) :: intg
type(process_t), pointer :: ptr
ptr => intg%process
end function integration_get_process_ptr
@ %def integration_get_process_ptr
@ Simply integrate, do a dummy integration if necessary. The [[integration]]
object exists only internally.
If the [[global]] environment is provided, the process object is appended to
the global stack. Otherwise, if [[local_stack]] is set, we append to the
local process stack. If this is unset, the [[process]] object is not recorded
permanently.
The [[init_only]] flag can be used to skip the actual integration part. We
will end up with a process object that is completely initialized, including
phase space configuration.
The [[eff_reset]] flag is to suppress numerical noise in the visualization
of the integration history.
<<Integrations: public>>=
public :: integrate_process
<<Integrations: sub interfaces>>=
module subroutine integrate_process &
(process_id, local, global, local_stack, init_only, eff_reset)
type(string_t), intent(in) :: process_id
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
logical, intent(in), optional :: local_stack, init_only, eff_reset
end subroutine integrate_process
<<Integrations: procedures>>=
module subroutine integrate_process &
(process_id, local, global, local_stack, init_only, eff_reset)
type(string_t), intent(in) :: process_id
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
logical, intent(in), optional :: local_stack, init_only, eff_reset
type(string_t) :: prclib_name
type(integration_t) :: intg
character(32) :: buffer
<<Integrations: integrate process: variables>>
<<Integrations: integrate process: init>>
if (.not. associated (local%prclib)) then
call msg_fatal ("Integrate: current process library is undefined")
return
end if
if (.not. local%prclib%is_active ()) then
call msg_message ("Integrate: current process library needs compilation")
prclib_name = local%prclib%get_name ()
call compile_library (prclib_name, local)
if (signal_is_pending ()) return
call msg_message ("Integrate: compilation done")
end if
call intg%init (process_id, local, global, local_stack, init_only)
if (signal_is_pending ()) return
if (present (init_only)) then
if (init_only) return
end if
if (intg%n_calls_test > 0) then
write (buffer, "(I0)") intg%n_calls_test
call msg_message ("Integrate: test (" // trim (buffer) // " calls) ...")
call intg%sampler_test ()
call msg_message ("Integrate: ... test complete.")
if (signal_is_pending ()) return
end if
<<Integrations: integrate process: end init>>
if (intg%phs_only) then
call msg_message ("Integrate: phase space only, skipping integration")
else
if (intg%process_has_me) then
call intg%integrate (local, eff_reset)
else
call intg%integrate_dummy ()
end if
end if
end subroutine integrate_process
@ %def integrate_process
<<Integrations: integrate process: variables>>=
@
<<Integrations: integrate process: init>>=
@
<<Integrations: integrate process: end init>>=
@
@ The parallelization leads to undefined behavior while writing simultaneously to one file.
The master worker has to initialize single-handed the corresponding library files and the phase space file.
The slave worker will wait with a blocking [[MPI_BCAST]] until they receive a logical flag.
<<MPI: Integrations: integrate process: variables>>=
type(var_list_t), pointer :: var_list
logical :: mpi_logging, process_init
integer :: rank, n_size
<<MPI: Integrations: integrate process: init>>=
if (debug_on) call msg_debug (D_MPI, "integrate_process")
var_list => local%get_var_list_ptr ()
process_init = .false.
call mpi_get_comm_id (n_size, rank)
mpi_logging = (("vamp2" == char (var_list%get_sval (var_str ("$integration_method"))) .and. &
& (n_size > 1)) .or. var_list%get_lval (var_str ("?mpi_logging")))
if (debug_on) call msg_debug (D_MPI, "n_size", rank)
if (debug_on) call msg_debug (D_MPI, "rank", rank)
if (debug_on) call msg_debug (D_MPI, "mpi_logging", mpi_logging)
if (rank /= 0) then
if (mpi_logging) then
call msg_message ("MPI: wait for master to finish process initialization ...")
end if
call MPI_bcast (process_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD)
else
process_init = .true.
end if
if (process_init) then
<<MPI: Integrations: integrate process: end init>>=
if (rank == 0) then
if (mpi_logging) then
call msg_message ("MPI: finish process initialization, load slaves ...")
end if
call MPI_bcast (process_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD)
end if
end if
call MPI_barrier (MPI_COMM_WORLD)
call mpi_set_logging (mpi_logging)
@ %def integrate_process_mpi
@
\subsection{Unit Tests}
Test module, followed by the stand-alone unit-test procedures.
<<[[integrations_ut.f90]]>>=
<<File header>>
module integrations_ut
use unit_tests
use integrations_uti
<<Standard module head>>
<<Integrations: public test>>
contains
<<Integrations: test driver>>
end module integrations_ut
@ %def integrations_ut
@
<<[[integrations_uti.f90]]>>=
<<File header>>
module integrations_uti
<<Use kinds>>
<<Use strings>>
use io_units
use ifiles
use lexers
use parser
use flavors
use interactions, only: reset_interaction_counter
use phs_forests
use eval_trees
use models
use rt_data
use process_configurations_ut, only: prepare_test_library
use compilations, only: compile_library
use integrations
use phs_wood_ut, only: write_test_phs_file
<<Standard module head>>
<<Integrations: test declarations>>
contains
<<Integrations: tests>>
end module integrations_uti
@ %def integrations_uti
@ API: driver for the unit tests below.
<<Integrations: public test>>=
public :: integrations_test
<<Integrations: test driver>>=
subroutine integrations_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Integrations: execute tests>>
end subroutine integrations_test
@ %def integrations_test
@
<<Integrations: public test>>=
public :: integrations_history_test
<<Integrations: test driver>>=
subroutine integrations_history_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Integrations: execute history tests>>
end subroutine integrations_history_test
@ %def integrations_history_test
@
\subsubsection{Integration of test process}
Compile and integrate an intrinsic test matrix element ([[prc_test]]
type). The phase-space implementation is [[phs_single]]
(single-particle phase space), the integrator is [[mci_midpoint]].
The cross section for the $2\to 2$ process $ss\to ss$ with its
constant matrix element is given by
\begin{equation}
\sigma = c\times f\times \Phi_2 \times |M|^2.
\end{equation}
$c$ is the conversion constant
\begin{equation}
c = 0.3894\times 10^{12}\;\mathrm{fb}\,\mathrm{GeV}^2.
\end{equation}
$f$ is the flux of the incoming particles with mass
$m=125\,\mathrm{GeV}$ and energy $\sqrt{s}=1000\,\mathrm{GeV}$
\begin{equation}
f = \frac{(2\pi)^4}{2\lambda^{1/2}(s,m^2,m^2)}
= \frac{(2\pi)^4}{2\sqrt{s}\,\sqrt{s - 4m^2}}
= 8.048\times 10^{-4}\;\mathrm{GeV}^{-2}
\end{equation}
$\Phi_2$ is the volume of the two-particle phase space
\begin{equation}
\Phi_2 = \frac{1}{4(2\pi)^5} = 2.5529\times 10^{-5}.
\end{equation}
The squared matrix element $|M|^2$ is unity.
Combining everything, we obtain
\begin{equation}
\sigma = 8000\;\mathrm{fb}
\end{equation}
This number should appear as the final result.
Note: In this and the following test, we reset the Fortran compiler and flag
variables immediately before they are printed, so the test is portable.
<<Integrations: execute tests>>=
call test (integrations_1, "integrations_1", &
"intrinsic test process", &
u, results)
<<Integrations: test declarations>>=
public :: integrations_1
<<Integrations: tests>>=
subroutine integrations_1 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname
type(rt_data_t), target :: global
write (u, "(A)") "* Test output: integrations_1"
write (u, "(A)") "* Purpose: integrate test process"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
libname = "integration_1"
procname = "prc_config_a"
call prepare_test_library (global, libname, 1)
call compile_library (libname, global)
call global%set_string (var_str ("$run_id"), &
var_str ("integrations1"), is_known = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known=.true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([1], [1000])
call reset_interaction_counter ()
call integrate_process (procname, global, local_stack=.true.)
call global%write (u, vars = [ &
var_str ("$method"), &
var_str ("sqrts"), &
var_str ("$integration_method"), &
var_str ("$phs_method"), &
var_str ("$run_id")])
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: integrations_1"
end subroutine integrations_1
@ %def integrations_1
@
\subsubsection{Integration with cuts}
Compile and integrate an intrinsic test matrix element ([[prc_test]]
type) with cuts set.
<<Integrations: execute tests>>=
call test (integrations_2, "integrations_2", &
"intrinsic test process with cut", &
u, results)
<<Integrations: test declarations>>=
public :: integrations_2
<<Integrations: tests>>=
subroutine integrations_2 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname
type(rt_data_t), target :: global
type(string_t) :: cut_expr_text
type(ifile_t) :: ifile
type(stream_t) :: stream
type(parse_tree_t) :: parse_tree
type(string_t), dimension(0) :: empty_string_array
write (u, "(A)") "* Test output: integrations_2"
write (u, "(A)") "* Purpose: integrate test process with cut"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
write (u, "(A)") "* Prepare a cut expression"
write (u, "(A)")
call syntax_pexpr_init ()
cut_expr_text = "all Pt > 100 [s]"
call ifile_append (ifile, cut_expr_text)
call stream_init (stream, ifile)
call parse_tree_init_lexpr (parse_tree, stream, .true.)
global%pn%cuts_lexpr => parse_tree%get_root_ptr ()
write (u, "(A)") "* Build and initialize a test process"
write (u, "(A)")
libname = "integration_3"
procname = "prc_config_a"
call prepare_test_library (global, libname, 1)
call compile_library (libname, global)
call global%set_string (var_str ("$run_id"), &
var_str ("integrations1"), is_known = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known=.true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([1], [1000])
call reset_interaction_counter ()
call integrate_process (procname, global, local_stack=.true.)
call global%write (u, vars = empty_string_array)
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: integrations_2"
end subroutine integrations_2
@ %def integrations_2
@
\subsubsection{Standard phase space}
Compile and integrate an intrinsic test matrix element ([[prc_test]]
type) using the default ([[phs_wood]]) phase-space implementation. We
use an explicit phase-space configuration file with a single channel
and integrate by [[mci_midpoint]].
<<Integrations: execute tests>>=
call test (integrations_3, "integrations_3", &
"standard phase space", &
u, results)
<<Integrations: test declarations>>=
public :: integrations_3
<<Integrations: tests>>=
subroutine integrations_3 (u)
<<Use kinds>>
<<Use strings>>
use interactions, only: reset_interaction_counter
use models
use rt_data
use process_configurations_ut, only: prepare_test_library
use compilations, only: compile_library
use integrations
implicit none
integer, intent(in) :: u
type(string_t) :: libname, procname
type(rt_data_t), target :: global
integer :: u_phs
write (u, "(A)") "* Test output: integrations_3"
write (u, "(A)") "* Purpose: integrate test process"
write (u, "(A)")
write (u, "(A)") "* Initialize process and parameters"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_phs_forest_init ()
call global%global_init ()
libname = "integration_3"
procname = "prc_config_a"
call prepare_test_library (global, libname, 1)
call compile_library (libname, global)
call global%set_string (var_str ("$run_id"), &
var_str ("integrations1"), is_known = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("default"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?phs_s_mapping"),&
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known=.true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
write (u, "(A)") "* Create a scratch phase-space file"
write (u, "(A)")
u_phs = free_unit ()
open (u_phs, file = "integrations_3.phs", &
status = "replace", action = "write")
call write_test_phs_file (u_phs, var_str ("prc_config_a_i1"))
close (u_phs)
call global%set_string (var_str ("$phs_file"),&
var_str ("integrations_3.phs"), is_known = .true.)
call global%it_list%init ([1], [1000])
write (u, "(A)") "* Integrate"
write (u, "(A)")
call reset_interaction_counter ()
call integrate_process (procname, global, local_stack=.true.)
call global%write (u, vars = [ &
var_str ("$phs_method"), &
var_str ("$phs_file")])
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_phs_forest_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: integrations_3"
end subroutine integrations_3
@ %def integrations_3
@
\subsubsection{VAMP integration}
Compile and integrate an intrinsic test matrix element ([[prc_test]]
type) using the single-channel ([[phs_single]]) phase-space
implementation. The integration method is [[vamp]].
<<Integrations: execute tests>>=
call test (integrations_4, "integrations_4", &
"VAMP integration (one iteration)", &
u, results)
<<Integrations: test declarations>>=
public :: integrations_4
<<Integrations: tests>>=
subroutine integrations_4 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname
type(rt_data_t), target :: global
write (u, "(A)") "* Test output: integrations_4"
write (u, "(A)") "* Purpose: integrate test process using VAMP"
write (u, "(A)")
write (u, "(A)") "* Initialize process and parameters"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
libname = "integrations_4_lib"
procname = "integrations_4"
call prepare_test_library (global, libname, 1, [procname])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("vamp"), is_known = .true.)
call global%set_log (var_str ("?use_vamp_equivalences"),&
.false., is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known=.true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([1], [1000])
write (u, "(A)") "* Integrate"
write (u, "(A)")
call reset_interaction_counter ()
call integrate_process (procname, global, local_stack=.true.)
call global%pacify (efficiency_reset = .true., error_reset = .true.)
call global%write (u, vars = [var_str ("$integration_method")], &
pacify = .true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: integrations_4"
end subroutine integrations_4
@ %def integrations_4
@
\subsubsection{Multiple iterations integration}
Compile and integrate an intrinsic test matrix element ([[prc_test]]
type) using the single-channel ([[phs_single]]) phase-space
implementation. The integration method is [[vamp]]. We launch three
iterations.
<<Integrations: execute tests>>=
call test (integrations_5, "integrations_5", &
"VAMP integration (three iterations)", &
u, results)
<<Integrations: test declarations>>=
public :: integrations_5
<<Integrations: tests>>=
subroutine integrations_5 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname
type(rt_data_t), target :: global
write (u, "(A)") "* Test output: integrations_5"
write (u, "(A)") "* Purpose: integrate test process using VAMP"
write (u, "(A)")
write (u, "(A)") "* Initialize process and parameters"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
libname = "integrations_5_lib"
procname = "integrations_5"
call prepare_test_library (global, libname, 1, [procname])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("vamp"), is_known = .true.)
call global%set_log (var_str ("?use_vamp_equivalences"),&
.false., is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known=.true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([3], [1000])
write (u, "(A)") "* Integrate"
write (u, "(A)")
call reset_interaction_counter ()
call integrate_process (procname, global, local_stack=.true.)
call global%pacify (efficiency_reset = .true., error_reset = .true.)
call global%write (u, vars = [var_str ("$integration_method")], &
pacify = .true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: integrations_5"
end subroutine integrations_5
@ %def integrations_5
@
\subsubsection{Multiple passes integration}
Compile and integrate an intrinsic test matrix element ([[prc_test]]
type) using the single-channel ([[phs_single]]) phase-space
implementation. The integration method is [[vamp]]. We launch three
passes with three iterations each.
<<Integrations: execute tests>>=
call test (integrations_6, "integrations_6", &
"VAMP integration (three passes)", &
u, results)
<<Integrations: test declarations>>=
public :: integrations_6
<<Integrations: tests>>=
subroutine integrations_6 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname
type(rt_data_t), target :: global
type(string_t), dimension(0) :: no_vars
write (u, "(A)") "* Test output: integrations_6"
write (u, "(A)") "* Purpose: integrate test process using VAMP"
write (u, "(A)")
write (u, "(A)") "* Initialize process and parameters"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
libname = "integrations_6_lib"
procname = "integrations_6"
call prepare_test_library (global, libname, 1, [procname])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("vamp"), is_known = .true.)
call global%set_log (var_str ("?use_vamp_equivalences"),&
.false., is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known=.true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([3, 3, 3], [1000, 1000, 1000], &
adapt = [.true., .true., .false.], &
adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")])
write (u, "(A)") "* Integrate"
write (u, "(A)")
call reset_interaction_counter ()
call integrate_process (procname, global, local_stack=.true.)
call global%pacify (efficiency_reset = .true., error_reset = .true.)
call global%write (u, vars = no_vars, pacify = .true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: integrations_6"
end subroutine integrations_6
@ %def integrations_6
@
\subsubsection{VAMP and default phase space}
Compile and integrate an intrinsic test matrix element ([[prc_test]]
type) using the default ([[phs_wood]]) phase-space
implementation. The integration method is [[vamp]]. We launch three
passes with three iterations each. We enable channel equivalences and
groves.
<<Integrations: execute tests>>=
call test (integrations_7, "integrations_7", &
"VAMP integration with wood phase space", &
u, results)
<<Integrations: test declarations>>=
public :: integrations_7
<<Integrations: tests>>=
subroutine integrations_7 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname
type(rt_data_t), target :: global
type(string_t), dimension(0) :: no_vars
integer :: iostat, u_phs
character(95) :: buffer
type(string_t) :: phs_file
logical :: exist
write (u, "(A)") "* Test output: integrations_7"
write (u, "(A)") "* Purpose: integrate test process using VAMP"
write (u, "(A)")
write (u, "(A)") "* Initialize process and parameters"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_phs_forest_init ()
call global%global_init ()
libname = "integrations_7_lib"
procname = "integrations_7"
call prepare_test_library (global, libname, 1, [procname])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("wood"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("vamp"), is_known = .true.)
call global%set_log (var_str ("?use_vamp_equivalences"),&
.true., is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?phs_s_mapping"),&
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known=.true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([3, 3, 3], [1000, 1000, 1000], &
adapt = [.true., .true., .false.], &
adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")])
write (u, "(A)") "* Integrate"
write (u, "(A)")
call reset_interaction_counter ()
call integrate_process (procname, global, local_stack=.true.)
call global%pacify (efficiency_reset = .true., error_reset = .true.)
call global%write (u, vars = no_vars, pacify = .true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_phs_forest_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Generated phase-space file"
write (u, "(A)")
phs_file = procname // ".r1.i1.phs"
inquire (file = char (phs_file), exist = exist)
if (exist) then
u_phs = free_unit ()
open (u_phs, file = char (phs_file), action = "read", status = "old")
iostat = 0
do while (iostat == 0)
read (u_phs, "(A)", iostat = iostat) buffer
if (iostat == 0) write (u, "(A)") trim (buffer)
end do
close (u_phs)
else
write (u, "(A)") "[file is missing]"
end if
write (u, "(A)")
write (u, "(A)") "* Test output end: integrations_7"
end subroutine integrations_7
@ %def integrations_7
@
\subsubsection{Structure functions}
Compile and integrate an intrinsic test matrix element ([[prc_test]]
type) using the default ([[phs_wood]]) phase-space
implementation. The integration method is [[vamp]]. There is a structure
function of type [[unit_test]].
We use a test structure function $f(x)=x$ for both beams. Together with the
$1/x_1x_2$ factor from the phase-space flux and a unit matrix element, we
should get the same result as previously for the process without structure
functions. There is a slight correction due to the $m_s$ mass which we set to
zero here.
<<Integrations: execute tests>>=
call test (integrations_8, "integrations_8", &
"integration with structure function", &
u, results)
<<Integrations: test declarations>>=
public :: integrations_8
<<Integrations: tests>>=
subroutine integrations_8 (u)
<<Use kinds>>
<<Use strings>>
use interactions, only: reset_interaction_counter
use phs_forests
use models
use rt_data
use process_configurations_ut, only: prepare_test_library
use compilations, only: compile_library
use integrations
implicit none
integer, intent(in) :: u
type(string_t) :: libname, procname
type(rt_data_t), target :: global
type(flavor_t) :: flv
type(string_t) :: name
write (u, "(A)") "* Test output: integrations_8"
write (u, "(A)") "* Purpose: integrate test process using VAMP &
&with structure function"
write (u, "(A)")
write (u, "(A)") "* Initialize process and parameters"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_phs_forest_init ()
call global%global_init ()
libname = "integrations_8_lib"
procname = "integrations_8"
call prepare_test_library (global, libname, 1, [procname])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("wood"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("vamp"), is_known = .true.)
call global%set_log (var_str ("?use_vamp_equivalences"),&
.true., is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?phs_s_mapping"),&
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known=.true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%model_set_real (var_str ("ms"), 0._default)
call reset_interaction_counter ()
call flv%init (25, global%model)
name = flv%get_name ()
call global%beam_structure%init_sf ([name, name], [1])
call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))
write (u, "(A)") "* Integrate"
write (u, "(A)")
call global%it_list%init ([1], [1000])
call integrate_process (procname, global, local_stack=.true.)
call global%write (u, vars = [var_str ("ms")])
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_phs_forest_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: integrations_8"
end subroutine integrations_8
@ %def integrations_8
@
\subsubsection{Integration with sign change}
Compile and integrate an intrinsic test matrix element ([[prc_test]]
type). The phase-space implementation is [[phs_single]]
(single-particle phase space), the integrator is [[mci_midpoint]].
The weight that is applied changes the sign in half of phase space.
The weight is $-3$ and $1$, respectively, so the total result is equal
to the original, but negative sign.
The efficiency should (approximately) become the average of $1$ and
$1/3$, that is $2/3$.
<<Integrations: execute tests>>=
call test (integrations_9, "integrations_9", &
"handle sign change", &
u, results)
<<Integrations: test declarations>>=
public :: integrations_9
<<Integrations: tests>>=
subroutine integrations_9 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname
type(rt_data_t), target :: global
type(string_t) :: wgt_expr_text
type(ifile_t) :: ifile
type(stream_t) :: stream
type(parse_tree_t) :: parse_tree
write (u, "(A)") "* Test output: integrations_9"
write (u, "(A)") "* Purpose: integrate test process"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
write (u, "(A)") "* Prepare a weight expression"
write (u, "(A)")
call syntax_pexpr_init ()
wgt_expr_text = "eval 2 * sgn (Pz) - 1 [s]"
call ifile_append (ifile, wgt_expr_text)
call stream_init (stream, ifile)
call parse_tree_init_expr (parse_tree, stream, .true.)
global%pn%weight_expr => parse_tree%get_root_ptr ()
write (u, "(A)") "* Build and evaluate a test process"
write (u, "(A)")
libname = "integration_9"
procname = "prc_config_a"
call prepare_test_library (global, libname, 1)
call compile_library (libname, global)
call global%set_string (var_str ("$run_id"), &
var_str ("integrations1"), is_known = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known=.true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([1], [1000])
call reset_interaction_counter ()
call integrate_process (procname, global, local_stack=.true.)
call global%write (u, vars = [ &
var_str ("$method"), &
var_str ("sqrts"), &
var_str ("$integration_method"), &
var_str ("$phs_method"), &
var_str ("$run_id")])
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: integrations_9"
end subroutine integrations_9
@ %def integrations_9
@
\subsubsection{Integration history for VAMP integration with default
phase space}
This test is only run when event analysis can be done.
<<Integrations: execute history tests>>=
call test (integrations_history_1, "integrations_history_1", &
"Test integration history files", &
u, results)
<<Integrations: test declarations>>=
public :: integrations_history_1
<<Integrations: tests>>=
subroutine integrations_history_1 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname
type(rt_data_t), target :: global
type(string_t), dimension(0) :: no_vars
integer :: iostat, u_his
character(91) :: buffer
type(string_t) :: his_file, ps_file, pdf_file
logical :: exist, exist_ps, exist_pdf
write (u, "(A)") "* Test output: integrations_history_1"
write (u, "(A)") "* Purpose: test integration history files"
write (u, "(A)")
write (u, "(A)") "* Initialize process and parameters"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_phs_forest_init ()
call global%global_init ()
libname = "integrations_history_1_lib"
procname = "integrations_history_1"
call global%set_log (var_str ("?vis_history"), &
.true., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?phs_s_mapping"),&
.false., is_known = .true.)
call prepare_test_library (global, libname, 1, [procname])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("wood"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("vamp"), is_known = .true.)
call global%set_log (var_str ("?use_vamp_equivalences"),&
.true., is_known = .true.)
call global%set_real (var_str ("error_threshold"),&
5E-6_default, is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known=.true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([2, 2, 2], [1000, 1000, 1000], &
adapt = [.true., .true., .false.], &
adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")])
write (u, "(A)") "* Integrate"
write (u, "(A)")
call reset_interaction_counter ()
call integrate_process (procname, global, local_stack=.true., &
eff_reset = .true.)
call global%pacify (efficiency_reset = .true., error_reset = .true.)
call global%write (u, vars = no_vars, pacify = .true.)
write (u, "(A)")
write (u, "(A)") "* Generated history files"
write (u, "(A)")
his_file = procname // ".r1.history.tex"
ps_file = procname // ".r1.history.ps"
pdf_file = procname // ".r1.history.pdf"
inquire (file = char (his_file), exist = exist)
if (exist) then
u_his = free_unit ()
open (u_his, file = char (his_file), action = "read", status = "old")
iostat = 0
do while (iostat == 0)
read (u_his, "(A)", iostat = iostat) buffer
if (iostat == 0) write (u, "(A)") trim (buffer)
end do
close (u_his)
else
write (u, "(A)") "[History LaTeX file is missing]"
end if
inquire (file = char (ps_file), exist = exist_ps)
if (exist_ps) then
write (u, "(A)") "[History Postscript file exists and is nonempty]"
else
write (u, "(A)") "[History Postscript file is missing/non-regular]"
end if
inquire (file = char (pdf_file), exist = exist_pdf)
if (exist_pdf) then
write (u, "(A)") "[History PDF file exists and is nonempty]"
else
write (u, "(A)") "[History PDF file is missing/non-regular]"
end if
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_phs_forest_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: integrations_history_1"
end subroutine integrations_history_1
@ %def integrations_history_1
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Event Streams}
This module manages I/O from/to multiple concurrent event streams.
Usually, there is at most one input stream, but several output
streams. For the latter, we set up an array which can hold [[eio_t]]
(event I/O) objects of different dynamic types simultaneously. One of
them may be marked as an input channel.
<<[[event_streams.f90]]>>=
<<File header>>
module event_streams
<<Use strings>>
use events
use event_handles, only: event_handle_t
use eio_data
use eio_base
use rt_data
use dispatch_transforms, only: dispatch_eio
<<Standard module head>>
<<Event streams: public>>
<<Event streams: types>>
interface
<<Event streams: sub interfaces>>
end interface
end module event_streams
@ %def event_streams
@
<<[[event_streams_sub.f90]]>>=
<<File header>>
submodule (event_streams) event_streams_s
use io_units
use diagnostics
implicit none
contains
<<Event streams: procedures>>
end submodule event_streams_s
@ %def event_streams_s
@
\subsection{Event Stream Array}
Each entry is an [[eio_t]] object. Since the type is dynamic, we need
a wrapper:
<<Event streams: types>>=
type :: event_stream_entry_t
class(eio_t), allocatable :: eio
end type event_stream_entry_t
@ %def event_stream_entry_t
@ An array of event-stream entry objects. If one of the entries is an
input channel, [[i_in]] is the corresponding index.
<<Event streams: public>>=
public :: event_stream_array_t
<<Event streams: types>>=
type :: event_stream_array_t
type(event_stream_entry_t), dimension(:), allocatable :: entry
integer :: i_in = 0
contains
<<Event streams: event stream array: TBP>>
end type event_stream_array_t
@ %def event_stream_array_t
@ Output.
<<Event streams: event stream array: TBP>>=
procedure :: write => event_stream_array_write
<<Event streams: sub interfaces>>=
module subroutine event_stream_array_write (object, unit)
class(event_stream_array_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine event_stream_array_write
<<Event streams: procedures>>=
module subroutine event_stream_array_write (object, unit)
class(event_stream_array_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
write (u, "(1x,A)") "Event stream array:"
if (allocated (object%entry)) then
select case (size (object%entry))
case (0)
write (u, "(3x,A)") "[empty]"
case default
do i = 1, size (object%entry)
if (i == object%i_in) write (u, "(1x,A)") "Input stream:"
call object%entry(i)%eio%write (u)
end do
end select
else
write (u, "(3x,A)") "[undefined]"
end if
end subroutine event_stream_array_write
@ %def event_stream_array_write
@ Check if there is content.
<<Event streams: event stream array: TBP>>=
procedure :: is_valid => event_stream_array_is_valid
<<Event streams: sub interfaces>>=
module function event_stream_array_is_valid (es_array) result (flag)
class(event_stream_array_t), intent(in) :: es_array
logical :: flag
end function event_stream_array_is_valid
<<Event streams: procedures>>=
module function event_stream_array_is_valid (es_array) result (flag)
class(event_stream_array_t), intent(in) :: es_array
logical :: flag
flag = allocated (es_array%entry)
end function event_stream_array_is_valid
@ %def event_stream_array_is_valid
@ Finalize all streams.
<<Event streams: event stream array: TBP>>=
procedure :: final => event_stream_array_final
<<Event streams: sub interfaces>>=
module subroutine event_stream_array_final (es_array)
class(event_stream_array_t), intent(inout) :: es_array
end subroutine event_stream_array_final
<<Event streams: procedures>>=
module subroutine event_stream_array_final (es_array)
class(event_stream_array_t), intent(inout) :: es_array
integer :: i
if (allocated (es_array%entry)) then
do i = 1, size (es_array%entry)
call es_array%entry(i)%eio%final ()
end do
end if
end subroutine event_stream_array_final
@ %def event_stream_array_final
@ Initialization. We use a generic [[sample]] name, open event I/O
objects for all provided stream types (using the [[dispatch_eio]]
routine), and initialize for the given list of process pointers. If
there is an [[input]] argument, this channel is initialized as an input
channel and appended to the array.
The [[input_data]] or, if not present, [[data]] may be modified. This
happens if we open a stream for reading and get new information there.
<<Event streams: event stream array: TBP>>=
procedure :: init => event_stream_array_init
<<Event streams: sub interfaces>>=
module subroutine event_stream_array_init &
(es_array, sample, stream_fmt, global, &
data, input, input_sample, input_data, allow_switch, &
checkpoint, callback, &
error)
class(event_stream_array_t), intent(out) :: es_array
type(string_t), intent(in) :: sample
type(string_t), dimension(:), intent(in) :: stream_fmt
type(rt_data_t), intent(in) :: global
type(event_sample_data_t), intent(inout), optional :: data
type(string_t), intent(in), optional :: input
type(string_t), intent(in), optional :: input_sample
type(event_sample_data_t), intent(inout), optional :: input_data
logical, intent(in), optional :: allow_switch
integer, intent(in), optional :: checkpoint
integer, intent(in), optional :: callback
logical, intent(out), optional :: error
end subroutine event_stream_array_init
<<Event streams: procedures>>=
module subroutine event_stream_array_init &
(es_array, sample, stream_fmt, global, &
data, input, input_sample, input_data, allow_switch, &
checkpoint, callback, &
error)
class(event_stream_array_t), intent(out) :: es_array
type(string_t), intent(in) :: sample
type(string_t), dimension(:), intent(in) :: stream_fmt
type(rt_data_t), intent(in) :: global
type(event_sample_data_t), intent(inout), optional :: data
type(string_t), intent(in), optional :: input
type(string_t), intent(in), optional :: input_sample
type(event_sample_data_t), intent(inout), optional :: input_data
logical, intent(in), optional :: allow_switch
integer, intent(in), optional :: checkpoint
integer, intent(in), optional :: callback
logical, intent(out), optional :: error
type(string_t) :: sample_in
integer :: n, i, n_output, i_input, i_checkpoint, i_callback
logical :: success, switch
if (present (input_sample)) then
sample_in = input_sample
else
sample_in = sample
end if
if (present (allow_switch)) then
switch = allow_switch
else
switch = .true.
end if
if (present (error)) then
error = .false.
end if
n = size (stream_fmt)
n_output = n
if (present (input)) then
n = n + 1
i_input = n
else
i_input = 0
end if
if (present (checkpoint)) then
n = n + 1
i_checkpoint = n
else
i_checkpoint = 0
end if
if (present (callback)) then
n = n + 1
i_callback = n
else
i_callback = 0
end if
allocate (es_array%entry (n))
if (i_checkpoint > 0) then
call dispatch_eio &
(es_array%entry(i_checkpoint)%eio, var_str ("checkpoint"), &
global%var_list, global%fallback_model, &
global%event_callback)
call es_array%entry(i_checkpoint)%eio%init_out (sample, data)
end if
if (i_callback > 0) then
call dispatch_eio &
(es_array%entry(i_callback)%eio, var_str ("callback"), &
global%var_list, global%fallback_model, &
global%event_callback)
call es_array%entry(i_callback)%eio%init_out (sample, data)
end if
if (i_input > 0) then
call dispatch_eio (es_array%entry(i_input)%eio, input, &
global%var_list, global%fallback_model, &
global%event_callback)
if (present (input_data)) then
call es_array%entry(i_input)%eio%init_in &
(sample_in, input_data, success)
else
call es_array%entry(i_input)%eio%init_in &
(sample_in, data, success)
end if
if (success) then
es_array%i_in = i_input
else if (present (input_sample)) then
if (present (error)) then
error = .true.
else
call msg_fatal ("Events: &
&parameter mismatch in input, aborting")
end if
else
call msg_message ("Events: &
&parameter mismatch, discarding old event set")
call es_array%entry(i_input)%eio%final ()
if (switch) then
call msg_message ("Events: generating new events")
call es_array%entry(i_input)%eio%init_out (sample, data)
end if
end if
end if
do i = 1, n_output
call dispatch_eio (es_array%entry(i)%eio, stream_fmt(i), &
global%var_list, global%fallback_model, &
global%event_callback)
call es_array%entry(i)%eio%init_out (sample, data)
end do
end subroutine event_stream_array_init
@ %def event_stream_array_init
@ Switch the (only) input channel to an output channel, so further
events are appended to the respective stream.
<<Event streams: event stream array: TBP>>=
procedure :: switch_inout => event_stream_array_switch_inout
<<Event streams: sub interfaces>>=
module subroutine event_stream_array_switch_inout (es_array)
class(event_stream_array_t), intent(inout) :: es_array
end subroutine event_stream_array_switch_inout
<<Event streams: procedures>>=
module subroutine event_stream_array_switch_inout (es_array)
class(event_stream_array_t), intent(inout) :: es_array
integer :: n
if (es_array%has_input ()) then
n = es_array%i_in
call es_array%entry(n)%eio%switch_inout ()
es_array%i_in = 0
else
call msg_bug ("Reading events: switch_inout: no input stream selected")
end if
end subroutine event_stream_array_switch_inout
@ %def event_stream_array_switch_inout
@ Output an event (with given process number) to all output streams.
If there is no output stream, do nothing.
<<Event streams: event stream array: TBP>>=
procedure :: output => event_stream_array_output
<<Event streams: sub interfaces>>=
module subroutine event_stream_array_output &
(es_array, event, i_prc, event_index, passed, pacify, event_handle)
class(event_stream_array_t), intent(inout) :: es_array
type(event_t), intent(in), target :: event
integer, intent(in) :: i_prc, event_index
logical, intent(in), optional :: passed, pacify
class(event_handle_t), intent(inout), optional :: event_handle
end subroutine event_stream_array_output
<<Event streams: procedures>>=
module subroutine event_stream_array_output &
(es_array, event, i_prc, event_index, passed, pacify, event_handle)
class(event_stream_array_t), intent(inout) :: es_array
type(event_t), intent(in), target :: event
integer, intent(in) :: i_prc, event_index
logical, intent(in), optional :: passed, pacify
class(event_handle_t), intent(inout), optional :: event_handle
logical :: increased
integer :: i
do i = 1, size (es_array%entry)
if (i /= es_array%i_in) then
associate (eio => es_array%entry(i)%eio)
if (eio%split) then
if (eio%split_n_evt > 0 .and. event_index > 1) then
if (mod (event_index, eio%split_n_evt) == 1) then
call eio%split_out ()
end if
else if (eio%split_n_kbytes > 0) then
call eio%update_split_count (increased)
if (increased) call eio%split_out ()
end if
end if
call eio%output (event, i_prc, reading = es_array%i_in /= 0, &
passed = passed, &
pacify = pacify, &
event_handle = event_handle)
end associate
end if
end do
end subroutine event_stream_array_output
@ %def event_stream_array_output
@ Input the [[i_prc]] index which selects the process for the current
event. This is separated from reading the event, because it
determines which event record to read. [[iostat]] may indicate an
error or an EOF condition, as usual.
<<Event streams: event stream array: TBP>>=
procedure :: input_i_prc => event_stream_array_input_i_prc
<<Event streams: sub interfaces>>=
module subroutine event_stream_array_input_i_prc (es_array, i_prc, iostat)
class(event_stream_array_t), intent(inout) :: es_array
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
end subroutine event_stream_array_input_i_prc
<<Event streams: procedures>>=
module subroutine event_stream_array_input_i_prc (es_array, i_prc, iostat)
class(event_stream_array_t), intent(inout) :: es_array
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
integer :: n
if (es_array%has_input ()) then
n = es_array%i_in
call es_array%entry(n)%eio%input_i_prc (i_prc, iostat)
else
call msg_fatal ("Reading events: no input stream selected")
end if
end subroutine event_stream_array_input_i_prc
@ %def event_stream_array_input_i_prc
@ Input an event from the selected input stream. [[iostat]] may indicate an
error or an EOF condition, as usual.
<<Event streams: event stream array: TBP>>=
procedure :: input_event => event_stream_array_input_event
<<Event streams: sub interfaces>>=
module subroutine event_stream_array_input_event &
(es_array, event, iostat, event_handle)
class(event_stream_array_t), intent(inout) :: es_array
type(event_t), intent(inout), target :: event
integer, intent(out) :: iostat
class(event_handle_t), intent(inout), optional :: event_handle
end subroutine event_stream_array_input_event
<<Event streams: procedures>>=
module subroutine event_stream_array_input_event &
(es_array, event, iostat, event_handle)
class(event_stream_array_t), intent(inout) :: es_array
type(event_t), intent(inout), target :: event
integer, intent(out) :: iostat
class(event_handle_t), intent(inout), optional :: event_handle
integer :: n
if (es_array%has_input ()) then
n = es_array%i_in
call es_array%entry(n)%eio%input_event (event, iostat, event_handle)
else
call msg_fatal ("Reading events: no input stream selected")
end if
end subroutine event_stream_array_input_event
@ %def event_stream_array_input_event
@ Skip an entry of eio\_t. Used to synchronize the event read-in for
NLO events.
<<Event streams: event stream array: TBP>>=
procedure :: skip_eio_entry => event_stream_array_skip_eio_entry
<<Event streams: sub interfaces>>=
module subroutine event_stream_array_skip_eio_entry (es_array, iostat)
class(event_stream_array_t), intent(inout) :: es_array
integer, intent(out) :: iostat
end subroutine event_stream_array_skip_eio_entry
<<Event streams: procedures>>=
module subroutine event_stream_array_skip_eio_entry (es_array, iostat)
class(event_stream_array_t), intent(inout) :: es_array
integer, intent(out) :: iostat
integer :: n
if (es_array%has_input ()) then
n = es_array%i_in
call es_array%entry(n)%eio%skip (iostat)
else
call msg_fatal ("Reading events: no input stream selected")
end if
end subroutine event_stream_array_skip_eio_entry
@ %def event_stream_array_skip_eio_entry
@ Return true if there is an input channel among the event streams.
<<Event streams: event stream array: TBP>>=
procedure :: has_input => event_stream_array_has_input
<<Event streams: sub interfaces>>=
module function event_stream_array_has_input (es_array) result (flag)
class(event_stream_array_t), intent(in) :: es_array
logical :: flag
end function event_stream_array_has_input
<<Event streams: procedures>>=
module function event_stream_array_has_input (es_array) result (flag)
class(event_stream_array_t), intent(in) :: es_array
logical :: flag
flag = es_array%i_in /= 0
end function event_stream_array_has_input
@ %def event_stream_array_has_input
@
\subsection{Unit Tests}
Test module, followed by the stand-alone unit-test procedures.
<<[[event_streams_ut.f90]]>>=
<<File header>>
module event_streams_ut
use unit_tests
use event_streams_uti
<<Standard module head>>
<<Event streams: public test>>
contains
<<Event streams: test driver>>
end module event_streams_ut
@
<<[[event_streams_uti.f90]]>>=
<<File header>>
module event_streams_uti
<<Use kinds>>
<<Use strings>>
use model_data
use eio_data
use process, only: process_t
use instances, only: process_instance_t
use models
use rt_data
use events
use event_streams
<<Standard module head>>
<<Event streams: test declarations>>
contains
<<Event streams: tests>>
end module event_streams_uti
@ %def event_streams_uti
@ API: driver for the unit tests below.
<<Event streams: public test>>=
public :: event_streams_test
<<Event streams: test driver>>=
subroutine event_streams_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Event streams: execute tests>>
end subroutine event_streams_test
@ %def event_streams_test
@
\subsubsection{Empty event stream}
This should set up an empty event output stream array, including
initialization, output, and finalization (which are all no-ops).
<<Event streams: execute tests>>=
call test (event_streams_1, "event_streams_1", &
"empty event stream array", &
u, results)
<<Event streams: test declarations>>=
public :: event_streams_1
<<Event streams: tests>>=
subroutine event_streams_1 (u)
integer, intent(in) :: u
type(event_stream_array_t) :: es_array
type(rt_data_t) :: global
type(event_t) :: event
type(string_t) :: sample
type(string_t), dimension(0) :: empty_string_array
write (u, "(A)") "* Test output: event_streams_1"
write (u, "(A)") "* Purpose: handle empty event stream array"
write (u, "(A)")
sample = "event_streams_1"
call es_array%init (sample, empty_string_array, global)
call es_array%output (event, 42, 1)
call es_array%write (u)
call es_array%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: event_streams_1"
end subroutine event_streams_1
@ %def event_streams_1
@
\subsubsection{Nontrivial event stream}
Here we generate a trivial event and choose [[raw]] output as an entry in
the stream array.
<<Event streams: execute tests>>=
call test (event_streams_2, "event_streams_2", &
"nontrivial event stream array", &
u, results)
<<Event streams: test declarations>>=
public :: event_streams_2
<<Event streams: tests>>=
subroutine event_streams_2 (u)
use processes_ut, only: prepare_test_process
integer, intent(in) :: u
type(event_stream_array_t) :: es_array
type(rt_data_t) :: global
type(model_data_t), target :: model
type(event_t), allocatable, target :: event
type(process_t), allocatable, target :: process
type(process_instance_t), allocatable, target :: process_instance
type(string_t) :: sample
type(string_t), dimension(0) :: empty_string_array
integer :: i_prc, iostat
write (u, "(A)") "* Test output: event_streams_2"
write (u, "(A)") "* Purpose: handle empty event stream array"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%init_fallback_model &
(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
call model%init_test ()
write (u, "(A)") "* Generate test process event"
write (u, "(A)")
allocate (process)
allocate (process_instance)
call prepare_test_process (process, process_instance, model, &
run_id = var_str ("run_test"))
call process_instance%setup_event_data ()
allocate (event)
call event%basic_init ()
call event%connect (process_instance, process%get_model_ptr ())
call event%generate (1, [0.4_default, 0.4_default])
call event%set_index (42)
call event%evaluate_expressions ()
call event%write (u)
write (u, "(A)")
write (u, "(A)") "* Allocate raw eio stream and write event to file"
write (u, "(A)")
sample = "event_streams_2"
call es_array%init (sample, [var_str ("raw")], global)
call es_array%output (event, 1, 1)
call es_array%write (u)
call es_array%final ()
write (u, "(A)")
write (u, "(A)") "* Reallocate raw eio stream for reading"
write (u, "(A)")
sample = "foo"
call es_array%init (sample, empty_string_array, global, &
input = var_str ("raw"), input_sample = var_str ("event_streams_2"))
call es_array%write (u)
write (u, "(A)")
write (u, "(A)") "* Reread event"
write (u, "(A)")
call es_array%input_i_prc (i_prc, iostat)
write (u, "(1x,A,I0)") "i_prc = ", i_prc
write (u, "(A)")
call es_array%input_event (event, iostat)
call es_array%final ()
call event%write (u)
call global%final ()
call model%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: event_streams_2"
end subroutine event_streams_2
@ %def event_streams_2
@
\subsubsection{Switch in/out}
Here we generate an event file and test switching from writing to
reading when the file is exhausted.
<<Event streams: execute tests>>=
call test (event_streams_3, "event_streams_3", &
"switch input/output", &
u, results)
<<Event streams: test declarations>>=
public :: event_streams_3
<<Event streams: tests>>=
subroutine event_streams_3 (u)
use processes_ut, only: prepare_test_process
integer, intent(in) :: u
type(event_stream_array_t) :: es_array
type(rt_data_t) :: global
type(model_data_t), target :: model
type(event_t), allocatable, target :: event
type(process_t), allocatable, target :: process
type(process_instance_t), allocatable, target :: process_instance
type(string_t) :: sample
type(string_t), dimension(0) :: empty_string_array
integer :: i_prc, iostat
write (u, "(A)") "* Test output: event_streams_3"
write (u, "(A)") "* Purpose: handle in/out switching"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%init_fallback_model &
(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
call model%init_test ()
write (u, "(A)") "* Generate test process event"
write (u, "(A)")
allocate (process)
allocate (process_instance)
call prepare_test_process (process, process_instance, model, &
run_id = var_str ("run_test"))
call process_instance%setup_event_data ()
allocate (event)
call event%basic_init ()
call event%connect (process_instance, process%get_model_ptr ())
call event%generate (1, [0.4_default, 0.4_default])
call event%increment_index ()
call event%evaluate_expressions ()
write (u, "(A)") "* Allocate raw eio stream and write event to file"
write (u, "(A)")
sample = "event_streams_3"
call es_array%init (sample, [var_str ("raw")], global)
call es_array%output (event, 1, 1)
call es_array%write (u)
call es_array%final ()
write (u, "(A)")
write (u, "(A)") "* Reallocate raw eio stream for reading"
write (u, "(A)")
call es_array%init (sample, empty_string_array, global, &
input = var_str ("raw"))
call es_array%write (u)
write (u, "(A)")
write (u, "(A)") "* Reread event"
write (u, "(A)")
call es_array%input_i_prc (i_prc, iostat)
call es_array%input_event (event, iostat)
write (u, "(A)") "* Attempt to read another event (fail), then generate"
write (u, "(A)")
call es_array%input_i_prc (i_prc, iostat)
if (iostat < 0) then
call es_array%switch_inout ()
call event%generate (1, [0.3_default, 0.3_default])
call event%increment_index ()
call event%evaluate_expressions ()
call es_array%output (event, 1, 2)
end if
call es_array%write (u)
call es_array%final ()
write (u, "(A)")
call event%write (u)
write (u, "(A)")
write (u, "(A)") "* Reallocate raw eio stream for reading"
write (u, "(A)")
call es_array%init (sample, empty_string_array, global, &
input = var_str ("raw"))
call es_array%write (u)
write (u, "(A)")
write (u, "(A)") "* Reread two events and display 2nd event"
write (u, "(A)")
call es_array%input_i_prc (i_prc, iostat)
call es_array%input_event (event, iostat)
call es_array%input_i_prc (i_prc, iostat)
call es_array%input_event (event, iostat)
call es_array%final ()
call event%write (u)
call global%final ()
call model%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: event_streams_3"
end subroutine event_streams_3
@ %def event_streams_3
@
\subsubsection{Checksum}
Here we generate an event file and repeat twice, once with identical
parameters and once with modified parameters.
<<Event streams: execute tests>>=
call test (event_streams_4, "event_streams_4", &
"check MD5 sum", &
u, results)
<<Event streams: test declarations>>=
public :: event_streams_4
<<Event streams: tests>>=
subroutine event_streams_4 (u)
integer, intent(in) :: u
type(event_stream_array_t) :: es_array
type(rt_data_t) :: global
type(process_t), allocatable, target :: process
type(string_t) :: sample
type(string_t), dimension(0) :: empty_string_array
type(event_sample_data_t) :: data
write (u, "(A)") "* Test output: event_streams_4"
write (u, "(A)") "* Purpose: handle in/out switching"
write (u, "(A)")
write (u, "(A)") "* Generate test process event"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%init_fallback_model &
(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
call global%set_log (var_str ("?check_event_file"), &
.true., is_known = .true.)
allocate (process)
write (u, "(A)") "* Allocate raw eio stream for writing"
write (u, "(A)")
sample = "event_streams_4"
data%md5sum_cfg = "1234567890abcdef1234567890abcdef"
call es_array%init (sample, [var_str ("raw")], global, data)
call es_array%write (u)
call es_array%final ()
write (u, "(A)")
write (u, "(A)") "* Reallocate raw eio stream for reading"
write (u, "(A)")
call es_array%init (sample, empty_string_array, global, &
data, input = var_str ("raw"))
call es_array%write (u)
call es_array%final ()
write (u, "(A)")
write (u, "(A)") "* Reallocate modified raw eio stream for reading (fail)"
write (u, "(A)")
data%md5sum_cfg = "1234567890______1234567890______"
call es_array%init (sample, empty_string_array, global, &
data, input = var_str ("raw"))
call es_array%write (u)
call es_array%final ()
write (u, "(A)")
write (u, "(A)") "* Repeat ignoring checksum"
write (u, "(A)")
call global%set_log (var_str ("?check_event_file"), &
.false., is_known = .true.)
call es_array%init (sample, empty_string_array, global, &
data, input = var_str ("raw"))
call es_array%write (u)
call es_array%final ()
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: event_streams_4"
end subroutine event_streams_4
@ %def event_streams_4
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Restricted Subprocesses}
This module provides an automatic means to construct restricted subprocesses
of a current process object. A restricted subprocess has the same initial and
final state as the current process, but a restricted set of Feynman graphs.
The actual application extracts the set of resonance histories that apply to
the process and uses this to construct subprocesses that are restricted to one
of those histories, respectively. The resonance histories are derived from
the phase-space setup. This implies that the method is tied to the OMega
matrix element generator and to the wood phase space method.
The processes are collected in a new process library that is generated
on-the-fly.
The [[resonant_subprocess_t]] object is intended as a component of the event
record, which manages all operations regarding resonance handling.
The run-time calculations are delegated to an event transform
([[evt_resonance_t]]), as a part of the event transform chain. The transform
selects one (or none) of the resonance histories, given the momentum
configuration, computes matrix elements and inserts resonances into the
particle set.
<<[[restricted_subprocesses.f90]]>>=
<<File header>>
module restricted_subprocesses
<<Use kinds>>
<<Use strings>>
use particle_specifiers, only: prt_spec_t
use resonances, only: resonance_history_t, resonance_history_set_t
use variables, only: var_list_t
use models, only: model_t
use event_transforms, only: evt_t
use resonance_insertion, only: evt_resonance_t
use rt_data, only: rt_data_t
use process_configurations, only: process_configuration_t
use process, only: process_t, process_ptr_t
use instances, only: process_instance_t, process_instance_ptr_t
<<Standard module head>>
<<Restricted subprocesses: public>>
<<Restricted subprocesses: types>>
<<Restricted subprocesses: interfaces>>
interface
<<Restricted subprocesses: sub interfaces>>
end interface
end module restricted_subprocesses
@ %def restricted_subprocesses
@
<<[[restricted_subprocesses_sub.f90]]>>=
<<File header>>
submodule (restricted_subprocesses) restricted_subprocesses_s
use diagnostics, only: msg_message, msg_fatal, msg_bug
use diagnostics, only: signal_is_pending
use io_units, only: given_output_unit
use format_defs, only: FMT_14, FMT_19
use string_utils, only: str
use process_libraries, only: process_component_def_t
use process_libraries, only: process_library_t
use process_libraries, only: STAT_ACTIVE
use prclib_stacks, only: prclib_entry_t
use compilations, only: compile_library
use integrations, only: integrate_process
implicit none
contains
<<Restricted subprocesses: procedures>>
end submodule restricted_subprocesses_s
@ %def restricted_subprocesses_s
@
\subsection{Process configuration}
We extend the [[process_configuration_t]] by another method for initialization
that takes into account a resonance history.
<<Restricted subprocesses: public>>=
public :: restricted_process_configuration_t
<<Restricted subprocesses: types>>=
type, extends (process_configuration_t) :: restricted_process_configuration_t
private
contains
<<Restricted subprocesses: restricted process configuration: TBP>>
end type restricted_process_configuration_t
@ %def restricted_process_configuration_t
@
Resonance history as an argument. We use it to override the [[restrictions]]
setting in a local variable list. Since we can construct the restricted
process only by using OMega, we enforce it as the ME method. Other settings
are taken from the variable list. The model will most likely be set, but we
insert a safeguard just in case.
Also, the resonant subprocess should not itself spawn resonant
subprocesses, so we unset [[?resonance_history]].
We have to create a local copy of the model here, via pointer
allocation. The reason is that the model as stored (via pointer) in
the base type will be finalized and deallocated.
The current implementation will generate a LO process, the optional
[[nlo_process]] is unset. (It is not obvious
whether the construction makes sense beyond LO.)
<<Restricted subprocesses: restricted process configuration: TBP>>=
procedure :: init_resonant_process
<<Restricted subprocesses: sub interfaces>>=
module subroutine init_resonant_process &
(prc_config, prc_name, prt_in, prt_out, res_history, model, var_list)
class(restricted_process_configuration_t), intent(out) :: prc_config
type(string_t), intent(in) :: prc_name
type(prt_spec_t), dimension(:), intent(in) :: prt_in
type(prt_spec_t), dimension(:), intent(in) :: prt_out
type(resonance_history_t), intent(in) :: res_history
type(model_t), intent(in), target :: model
type(var_list_t), intent(in), target :: var_list
end subroutine init_resonant_process
<<Restricted subprocesses: procedures>>=
module subroutine init_resonant_process &
(prc_config, prc_name, prt_in, prt_out, res_history, model, var_list)
class(restricted_process_configuration_t), intent(out) :: prc_config
type(string_t), intent(in) :: prc_name
type(prt_spec_t), dimension(:), intent(in) :: prt_in
type(prt_spec_t), dimension(:), intent(in) :: prt_out
type(resonance_history_t), intent(in) :: res_history
type(model_t), intent(in), target :: model
type(var_list_t), intent(in), target :: var_list
type(model_t), pointer :: local_model
type(var_list_t) :: local_var_list
allocate (local_model)
call local_model%init_instance (model)
call local_var_list%link (var_list)
call local_var_list%append_string (var_str ("$model_name"), &
sval = local_model%get_name (), &
intrinsic=.true.)
call local_var_list%append_string (var_str ("$method"), &
sval = var_str ("omega"), &
intrinsic=.true.)
call local_var_list%append_string (var_str ("$restrictions"), &
sval = res_history%as_omega_string (size (prt_in)), &
intrinsic = .true.)
call local_var_list%append_log (var_str ("?resonance_history"), &
lval = .false., &
intrinsic = .true.)
call prc_config%init (prc_name, size (prt_in), 1, &
local_model, local_var_list)
call prc_config%setup_component (1, &
prt_in, prt_out, &
local_model, local_var_list)
end subroutine init_resonant_process
@ %def init_resonant_process
@
\subsection{Resonant-subprocess set manager}
This data type enables generation of a library of resonant subprocesses for a
given master process, and it allows for convenient access. The matrix
elements from the subprocesses can be used as channel weights to activate a
selector, which then returns a preferred channel via some random number
generator.
<<Restricted subprocesses: public>>=
public :: resonant_subprocess_set_t
<<Restricted subprocesses: types>>=
type :: resonant_subprocess_set_t
private
integer, dimension(:), allocatable :: n_history
type(resonance_history_set_t), dimension(:), allocatable :: res_history_set
logical :: lib_active = .false.
type(string_t) :: libname
type(string_t), dimension(:), allocatable :: proc_id
type(process_ptr_t), dimension(:), allocatable :: subprocess
type(process_instance_ptr_t), dimension(:), allocatable :: instance
logical :: filled = .false.
type(evt_resonance_t), pointer :: evt => null ()
contains
<<Restricted subprocesses: resonant subprocess set: TBP>>
end type resonant_subprocess_set_t
@ %def resonant_subprocess_set_t
@ Output
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: write => resonant_subprocess_set_write
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_write (prc_set, unit, testflag)
class(resonant_subprocess_set_t), intent(in) :: prc_set
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
end subroutine resonant_subprocess_set_write
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_write (prc_set, unit, testflag)
class(resonant_subprocess_set_t), intent(in) :: prc_set
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
logical :: truncate
integer :: u, i
u = given_output_unit (unit)
truncate = .false.; if (present (testflag)) truncate = testflag
write (u, "(1x,A)") "Resonant subprocess set:"
if (allocated (prc_set%n_history)) then
if (any (prc_set%n_history > 0)) then
do i = 1, size (prc_set%n_history)
if (prc_set%n_history(i) > 0) then
write (u, "(1x,A,I0)") "Component #", i
call prc_set%res_history_set(i)%write (u, indent=1)
end if
end do
if (prc_set%lib_active) then
write (u, "(3x,A,A,A)") "Process library = '", &
char (prc_set%libname), "'"
else
write (u, "(3x,A)") "Process library: [inactive]"
end if
if (associated (prc_set%evt)) then
if (truncate) then
write (u, "(3x,A,1x," // FMT_14 // ")") &
"Process sqme =", prc_set%get_master_sqme ()
else
write (u, "(3x,A,1x," // FMT_19 // ")") &
"Process sqme =", prc_set%get_master_sqme ()
end if
end if
if (associated (prc_set%evt)) then
write (u, "(3x,A)") "Event transform: associated"
write (u, "(2x)", advance="no")
call prc_set%evt%write_selector (u, testflag)
else
write (u, "(3x,A)") "Event transform: not associated"
end if
else
write (u, "(2x,A)") "[empty]"
end if
else
write (u, "(3x,A)") "[not allocated]"
end if
end subroutine resonant_subprocess_set_write
@ %def resonant_subprocess_set_write
@
\subsection{Resonance history set}
Initialize subprocess set with an array of pre-created resonance
history sets.
Safeguard: if there are no resonances in the input, initialize the local set
as empty, but complete.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: init => resonant_subprocess_set_init
procedure :: fill_resonances => resonant_subprocess_set_fill_resonances
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_init (prc_set, n_component)
class(resonant_subprocess_set_t), intent(out) :: prc_set
integer, intent(in) :: n_component
end subroutine resonant_subprocess_set_init
module subroutine resonant_subprocess_set_fill_resonances (prc_set, &
res_history_set, i_component)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
type(resonance_history_set_t), intent(in) :: res_history_set
integer, intent(in) :: i_component
end subroutine resonant_subprocess_set_fill_resonances
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_init (prc_set, n_component)
class(resonant_subprocess_set_t), intent(out) :: prc_set
integer, intent(in) :: n_component
allocate (prc_set%res_history_set (n_component))
allocate (prc_set%n_history (n_component), source = 0)
end subroutine resonant_subprocess_set_init
module subroutine resonant_subprocess_set_fill_resonances (prc_set, &
res_history_set, i_component)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
type(resonance_history_set_t), intent(in) :: res_history_set
integer, intent(in) :: i_component
prc_set%n_history(i_component) = res_history_set%get_n_history ()
if (prc_set%n_history(i_component) > 0) then
prc_set%res_history_set(i_component) = res_history_set
else
call prc_set%res_history_set(i_component)%init (initial_size = 0)
call prc_set%res_history_set(i_component)%freeze ()
end if
end subroutine resonant_subprocess_set_fill_resonances
@ %def resonant_subprocess_set_init
@ %def resonant_subprocess_set_fill_resonances
@ Return the resonance history set.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: get_resonance_history_set &
=> resonant_subprocess_set_get_resonance_history_set
<<Restricted subprocesses: sub interfaces>>=
module function resonant_subprocess_set_get_resonance_history_set &
(prc_set) result (res_history_set)
class(resonant_subprocess_set_t), intent(in) :: prc_set
type(resonance_history_set_t), dimension(:), allocatable :: &
res_history_set
end function resonant_subprocess_set_get_resonance_history_set
<<Restricted subprocesses: procedures>>=
module function resonant_subprocess_set_get_resonance_history_set &
(prc_set) result (res_history_set)
class(resonant_subprocess_set_t), intent(in) :: prc_set
type(resonance_history_set_t), dimension(:), allocatable :: &
res_history_set
res_history_set = prc_set%res_history_set
end function resonant_subprocess_set_get_resonance_history_set
@ %def resonant_subprocess_set_get_resonance_history_set
@
\subsection{Library for the resonance history set}
The recommended library name: append [[_R]] to the process name.
<<Restricted subprocesses: public>>=
public :: get_libname_res
<<Restricted subprocesses: sub interfaces>>=
elemental module function get_libname_res (proc_id) result (libname)
type(string_t), intent(in) :: proc_id
type(string_t) :: libname
end function get_libname_res
<<Restricted subprocesses: procedures>>=
elemental module function get_libname_res (proc_id) result (libname)
type(string_t), intent(in) :: proc_id
type(string_t) :: libname
libname = proc_id // "_R"
end function get_libname_res
@ %def get_libname_res
@ Here we scan the global process library whether any
processes require resonant subprocesses to be constructed. If yes,
create process objects with phase space and construct the process
libraries as usual. Then append the library names to the array.
The temporary integration objects should carry the [[phs_only]]
flag. We set this in the local environment.
Once a process object with resonance histories (derived from phase
space) has been created, we extract the resonance histories and use
them, together with the process definition, to create the new library.
Finally, compile the library.
<<Restricted subprocesses: public>>=
public :: spawn_resonant_subprocess_libraries
<<Restricted subprocesses: sub interfaces>>=
module subroutine spawn_resonant_subprocess_libraries &
(libname, local, global, libname_res)
type(string_t), intent(in) :: libname
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), target :: global
type(string_t), dimension(:), allocatable, intent(inout) :: libname_res
end subroutine spawn_resonant_subprocess_libraries
<<Restricted subprocesses: procedures>>=
module subroutine spawn_resonant_subprocess_libraries &
(libname, local, global, libname_res)
type(string_t), intent(in) :: libname
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), target :: global
type(string_t), dimension(:), allocatable, intent(inout) :: libname_res
type(process_library_t), pointer :: lib
type(string_t), dimension(:), allocatable :: process_id_res
type(process_t), pointer :: process
type(resonance_history_set_t) :: res_history_set
type(process_component_def_t), pointer :: process_component_def
logical :: phs_only_saved, exist
integer :: i_proc, i_component
lib => global%prclib_stack%get_library_ptr (libname)
call lib%get_process_id_req_resonant (process_id_res)
if (size (process_id_res) > 0) then
call msg_message ("Creating resonant-subprocess libraries &
&for library '" // char (libname) // "'")
libname_res = get_libname_res (process_id_res)
phs_only_saved = local%var_list%get_lval (var_str ("?phs_only"))
call local%var_list%set_log &
(var_str ("?phs_only"), .true., is_known=.true.)
do i_proc = 1, size (process_id_res)
associate (proc_id => process_id_res (i_proc))
call msg_message ("Process '" // char (proc_id) // "': &
&constructing phase space for resonance structure")
call integrate_process (proc_id, local, global)
process => global%process_stack%get_process_ptr (proc_id)
call create_library (libname_res(i_proc), global, exist)
if (.not. exist) then
do i_component = 1, process%get_n_components ()
call process%extract_resonance_history_set &
(res_history_set, i_component = i_component)
process_component_def &
=> process%get_component_def_ptr (i_component)
call add_to_library (libname_res(i_proc), &
res_history_set, &
process_component_def%get_prt_spec_in (), &
process_component_def%get_prt_spec_out (), &
global)
end do
call msg_message ("Process library '" &
// char (libname_res(i_proc)) &
// "': created")
end if
call global%update_prclib (lib)
end associate
end do
call local%var_list%set_log &
(var_str ("?phs_only"), phs_only_saved, is_known=.true.)
end if
end subroutine spawn_resonant_subprocess_libraries
@ %def spawn_resonant_subprocess_libraries
@ This is another version of the library constructor, bound to a
restricted-subprocess set object. Create the appropriate
process library, add processes, and close the library.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: create_library => resonant_subprocess_set_create_library
procedure :: add_to_library => resonant_subprocess_set_add_to_library
procedure :: freeze_library => resonant_subprocess_set_freeze_library
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_create_library (prc_set, &
libname, global, exist)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
type(string_t), intent(in) :: libname
type(rt_data_t), intent(inout), target :: global
logical, intent(out) :: exist
end subroutine resonant_subprocess_set_create_library
module subroutine resonant_subprocess_set_add_to_library (prc_set, &
i_component, prt_in, prt_out, global)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
integer, intent(in) :: i_component
type(prt_spec_t), dimension(:), intent(in) :: prt_in
type(prt_spec_t), dimension(:), intent(in) :: prt_out
type(rt_data_t), intent(inout), target :: global
end subroutine resonant_subprocess_set_add_to_library
module subroutine resonant_subprocess_set_freeze_library (prc_set, global)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
type(rt_data_t), intent(inout), target :: global
end subroutine resonant_subprocess_set_freeze_library
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_create_library (prc_set, &
libname, global, exist)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
type(string_t), intent(in) :: libname
type(rt_data_t), intent(inout), target :: global
logical, intent(out) :: exist
prc_set%libname = libname
call create_library (prc_set%libname, global, exist)
end subroutine resonant_subprocess_set_create_library
module subroutine resonant_subprocess_set_add_to_library (prc_set, &
i_component, prt_in, prt_out, global)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
integer, intent(in) :: i_component
type(prt_spec_t), dimension(:), intent(in) :: prt_in
type(prt_spec_t), dimension(:), intent(in) :: prt_out
type(rt_data_t), intent(inout), target :: global
call add_to_library (prc_set%libname, &
prc_set%res_history_set(i_component), &
prt_in, prt_out, global)
end subroutine resonant_subprocess_set_add_to_library
module subroutine resonant_subprocess_set_freeze_library (prc_set, global)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
type(rt_data_t), intent(inout), target :: global
type(prclib_entry_t), pointer :: lib_entry
type(process_library_t), pointer :: lib
lib => global%prclib_stack%get_library_ptr (prc_set%libname)
call lib%get_process_id_list (prc_set%proc_id)
prc_set%lib_active = .true.
end subroutine resonant_subprocess_set_freeze_library
@ %def resonant_subprocess_set_create_library
@ %def resonant_subprocess_set_add_to_library
@ %def resonant_subprocess_set_freeze_library
@ The common parts of the procedures above: (i) create a new process
library or recover it, (ii) for each history, create a
process configuration and record it.
<<Restricted subprocesses: procedures>>=
subroutine create_library (libname, global, exist)
type(string_t), intent(in) :: libname
type(rt_data_t), intent(inout), target :: global
logical, intent(out) :: exist
type(prclib_entry_t), pointer :: lib_entry
type(process_library_t), pointer :: lib
type(resonance_history_t) :: res_history
type(string_t), dimension(:), allocatable :: proc_id
type(restricted_process_configuration_t) :: prc_config
integer :: i
lib => global%prclib_stack%get_library_ptr (libname)
exist = associated (lib)
if (.not. exist) then
call msg_message ("Creating library for resonant subprocesses '" &
// char (libname) // "'")
allocate (lib_entry)
call lib_entry%init (libname)
lib => lib_entry%process_library_t
call global%add_prclib (lib_entry)
else
call msg_message ("Using library for resonant subprocesses '" &
// char (libname) // "'")
call global%update_prclib (lib)
end if
end subroutine create_library
subroutine add_to_library (libname, res_history_set, prt_in, prt_out, global)
type(string_t), intent(in) :: libname
type(resonance_history_set_t), intent(in) :: res_history_set
type(prt_spec_t), dimension(:), intent(in) :: prt_in
type(prt_spec_t), dimension(:), intent(in) :: prt_out
type(rt_data_t), intent(inout), target :: global
type(prclib_entry_t), pointer :: lib_entry
type(process_library_t), pointer :: lib
type(resonance_history_t) :: res_history
type(string_t), dimension(:), allocatable :: proc_id
type(restricted_process_configuration_t) :: prc_config
integer :: n0, i
lib => global%prclib_stack%get_library_ptr (libname)
if (associated (lib)) then
n0 = lib%get_n_processes ()
allocate (proc_id (res_history_set%get_n_history ()))
do i = 1, size (proc_id)
proc_id(i) = libname // str (n0 + i)
res_history = res_history_set%get_history(i)
call prc_config%init_resonant_process (proc_id(i), &
prt_in, prt_out, &
res_history, &
global%model, global%var_list)
call msg_message ("Resonant subprocess #" &
// char (str(n0+i)) // ": " &
// char (res_history%as_omega_string (size (prt_in))))
call prc_config%record (global)
if (signal_is_pending ()) return
end do
else
call msg_bug ("Adding subprocesses: library '" &
// char (libname) // "' not found")
end if
end subroutine add_to_library
@ %def create_library
@ %def add_to_library
@ Compile the generated library, required settings taken from the
[[global]] data set.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: compile_library => resonant_subprocess_set_compile_library
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_compile_library (prc_set, global)
class(resonant_subprocess_set_t), intent(in) :: prc_set
type(rt_data_t), intent(inout), target :: global
end subroutine resonant_subprocess_set_compile_library
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_compile_library (prc_set, global)
class(resonant_subprocess_set_t), intent(in) :: prc_set
type(rt_data_t), intent(inout), target :: global
type(process_library_t), pointer :: lib
lib => global%prclib_stack%get_library_ptr (prc_set%libname)
if (lib%get_status () < STAT_ACTIVE) then
call compile_library (prc_set%libname, global)
end if
end subroutine resonant_subprocess_set_compile_library
@ %def resonant_subprocess_set_compile_library
@ Check if the library has been created / the process has been evaluated.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: is_active => resonant_subprocess_set_is_active
<<Restricted subprocesses: sub interfaces>>=
module function resonant_subprocess_set_is_active (prc_set) result (flag)
class(resonant_subprocess_set_t), intent(in) :: prc_set
logical :: flag
end function resonant_subprocess_set_is_active
<<Restricted subprocesses: procedures>>=
module function resonant_subprocess_set_is_active (prc_set) result (flag)
class(resonant_subprocess_set_t), intent(in) :: prc_set
logical :: flag
flag = prc_set%lib_active
end function resonant_subprocess_set_is_active
@ %def resonant_subprocess_set_is_active
@ Return number of generated process objects, library, and process IDs.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: get_n_process => resonant_subprocess_set_get_n_process
procedure :: get_libname => resonant_subprocess_set_get_libname
procedure :: get_proc_id => resonant_subprocess_set_get_proc_id
<<Restricted subprocesses: sub interfaces>>=
module function resonant_subprocess_set_get_n_process (prc_set) result (n)
class(resonant_subprocess_set_t), intent(in) :: prc_set
integer :: n
end function resonant_subprocess_set_get_n_process
module function resonant_subprocess_set_get_libname &
(prc_set) result (libname)
class(resonant_subprocess_set_t), intent(in) :: prc_set
type(string_t) :: libname
end function resonant_subprocess_set_get_libname
module function resonant_subprocess_set_get_proc_id &
(prc_set, i) result (proc_id)
class(resonant_subprocess_set_t), intent(in) :: prc_set
integer, intent(in) :: i
type(string_t) :: proc_id
end function resonant_subprocess_set_get_proc_id
<<Restricted subprocesses: procedures>>=
module function resonant_subprocess_set_get_n_process (prc_set) result (n)
class(resonant_subprocess_set_t), intent(in) :: prc_set
integer :: n
if (prc_set%lib_active) then
n = size (prc_set%proc_id)
else
n = 0
end if
end function resonant_subprocess_set_get_n_process
module function resonant_subprocess_set_get_libname (prc_set) result (libname)
class(resonant_subprocess_set_t), intent(in) :: prc_set
type(string_t) :: libname
if (prc_set%lib_active) then
libname = prc_set%libname
else
libname = ""
end if
end function resonant_subprocess_set_get_libname
module function resonant_subprocess_set_get_proc_id &
(prc_set, i) result (proc_id)
class(resonant_subprocess_set_t), intent(in) :: prc_set
integer, intent(in) :: i
type(string_t) :: proc_id
if (allocated (prc_set%proc_id)) then
proc_id = prc_set%proc_id(i)
else
proc_id = ""
end if
end function resonant_subprocess_set_get_proc_id
@ %def resonant_subprocess_set_get_n_process
@ %def resonant_subprocess_set_get_libname
@ %def resonant_subprocess_set_get_proc_id
@
\subsection{Process objects and instances}
Prepare process objects for all entries in the resonant-subprocesses
library. The process objects are appended to the global process
stack. A local environment can be used where we place temporary
variable settings that affect process-object generation. We
initialize the processes, such that we can evaluate matrix elements,
but we do not need to integrate them.
The internal procedure [[prepare_process]] is an abridged version of
the procedure with this name in the [[simulations]] module.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: prepare_process_objects &
=> resonant_subprocess_set_prepare_process_objects
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_prepare_process_objects &
(prc_set, local, global)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
end subroutine resonant_subprocess_set_prepare_process_objects
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_prepare_process_objects &
(prc_set, local, global)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
type(rt_data_t), pointer :: current
type(process_library_t), pointer :: lib
type(string_t) :: phs_method_saved, integration_method_saved
type(string_t) :: proc_id, libname_cur, libname_res
integer :: i, n
if (.not. prc_set%is_active ()) return
if (present (global)) then
current => global
else
current => local
end if
libname_cur = current%prclib%get_name ()
libname_res = prc_set%get_libname ()
lib => current%prclib_stack%get_library_ptr (libname_res)
if (associated (lib)) call current%update_prclib (lib)
phs_method_saved = local%get_sval (var_str ("$phs_method"))
integration_method_saved = local%get_sval (var_str ("$integration_method"))
call local%set_string (var_str ("$phs_method"), &
var_str ("none"), is_known = .true.)
call local%set_string (var_str ("$integration_method"), &
var_str ("none"), is_known = .true.)
n = prc_set%get_n_process ()
allocate (prc_set%subprocess (n))
do i = 1, n
proc_id = prc_set%get_proc_id (i)
call prepare_process (prc_set%subprocess(i)%p, proc_id)
if (signal_is_pending ()) return
end do
call local%set_string (var_str ("$phs_method"), &
phs_method_saved, is_known = .true.)
call local%set_string (var_str ("$integration_method"), &
integration_method_saved, is_known = .true.)
lib => current%prclib_stack%get_library_ptr (libname_cur)
if (associated (lib)) call current%update_prclib (lib)
contains
subroutine prepare_process (process, process_id)
type(process_t), pointer, intent(out) :: process
type(string_t), intent(in) :: process_id
call msg_message ("Simulate: initializing resonant subprocess '" &
// char (process_id) // "'")
if (present (global)) then
call integrate_process (process_id, local, global, &
init_only = .true.)
else
call integrate_process (process_id, local, local_stack = .true., &
init_only = .true.)
end if
process => current%process_stack%get_process_ptr (process_id)
if (.not. associated (process)) then
call msg_fatal ("Simulate: resonant subprocess '" &
// char (process_id) // "' could not be initialized: aborting")
end if
end subroutine prepare_process
end subroutine resonant_subprocess_set_prepare_process_objects
@ %def resonant_subprocess_set_prepare_process_objects
@ Workspace for the resonant subprocesses.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: prepare_process_instances &
=> resonant_subprocess_set_prepare_process_instances
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_prepare_process_instances &
(prc_set, global)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
type(rt_data_t), intent(in), target :: global
end subroutine resonant_subprocess_set_prepare_process_instances
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_prepare_process_instances &
(prc_set, global)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
type(rt_data_t), intent(in), target :: global
integer :: i, n
if (.not. prc_set%is_active ()) return
n = size (prc_set%subprocess)
allocate (prc_set%instance (n))
do i = 1, n
allocate (prc_set%instance(i)%p)
call prc_set%instance(i)%p%init (prc_set%subprocess(i)%p)
call prc_set%instance(i)%p%setup_event_data (global%model)
end do
end subroutine resonant_subprocess_set_prepare_process_instances
@ %def resonant_subprocess_set_prepare_process_instances
@
\subsection{Event transform connection}
The idea is that the resonance-insertion event transform has been
allocated somewhere (namely, in the standard event-transform chain),
but we maintain a link such that we can inject matrix-element results
event by event. The event transform holds a selector, to choose one
of the resonance histories (or none), and it manages resonance
insertion for the particle set.
The data that the event transform requires can be provided here. The
resonance history set has already been assigned with the [[dispatch]]
initializer. Here, we supply the set of subprocess instances that we
have generated (see above). The master-process instance is set
when we [[connect]] the transform by the standard method.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: connect_transform => &
resonant_subprocess_set_connect_transform
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_connect_transform (prc_set, evt)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
class(evt_t), intent(in), target :: evt
end subroutine resonant_subprocess_set_connect_transform
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_connect_transform (prc_set, evt)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
class(evt_t), intent(in), target :: evt
select type (evt)
type is (evt_resonance_t)
prc_set%evt => evt
call prc_set%evt%set_subprocess_instances (prc_set%instance)
class default
call msg_bug ("Resonant subprocess set: event transform has wrong type")
end select
end subroutine resonant_subprocess_set_connect_transform
@ %def resonant_subprocess_set_connect_transform
@ Set the on-shell limit value in the connected transform.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: set_on_shell_limit => resonant_subprocess_set_on_shell_limit
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_on_shell_limit &
(prc_set, on_shell_limit)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
real(default), intent(in) :: on_shell_limit
end subroutine resonant_subprocess_set_on_shell_limit
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_on_shell_limit &
(prc_set, on_shell_limit)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
real(default), intent(in) :: on_shell_limit
call prc_set%evt%set_on_shell_limit (on_shell_limit)
end subroutine resonant_subprocess_set_on_shell_limit
@ %def resonant_subprocess_set_on_shell_limit
@ Set the Gaussian turnoff parameter in the connected transform.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: set_on_shell_turnoff => resonant_subprocess_set_on_shell_turnoff
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_on_shell_turnoff &
(prc_set, on_shell_turnoff)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
real(default), intent(in) :: on_shell_turnoff
end subroutine resonant_subprocess_set_on_shell_turnoff
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_on_shell_turnoff &
(prc_set, on_shell_turnoff)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
real(default), intent(in) :: on_shell_turnoff
call prc_set%evt%set_on_shell_turnoff (on_shell_turnoff)
end subroutine resonant_subprocess_set_on_shell_turnoff
@ %def resonant_subprocess_set_on_shell_turnoff
@ Reweight (suppress) the background contribution probability, for the
kinematics where a resonance history is active.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: set_background_factor &
=> resonant_subprocess_set_background_factor
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_background_factor &
(prc_set, background_factor)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
real(default), intent(in) :: background_factor
end subroutine resonant_subprocess_set_background_factor
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_background_factor &
(prc_set, background_factor)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
real(default), intent(in) :: background_factor
call prc_set%evt%set_background_factor (background_factor)
end subroutine resonant_subprocess_set_background_factor
@ %def resonant_subprocess_set_background_factor
@
\subsection{Wrappers for runtime calculations}
All runtime calculations are delegated to the event transform. The
following procedures are essentially redundant wrappers. We retain
them for a unit test below.
Debugging aid:
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: dump_instances => resonant_subprocess_set_dump_instances
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_dump_instances &
(prc_set, unit, testflag)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
end subroutine resonant_subprocess_set_dump_instances
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_dump_instances &
(prc_set, unit, testflag)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
integer :: i, n, u
u = given_output_unit (unit)
write (u, "(A)") "*** Process instances of resonant subprocesses"
write (u, *)
n = size (prc_set%subprocess)
do i = 1, n
associate (instance => prc_set%instance(i)%p)
call instance%write (u, testflag)
write (u, *)
write (u, *)
end associate
end do
end subroutine resonant_subprocess_set_dump_instances
@ %def resonant_subprocess_set_dump_instances
@ Inject the current kinematics configuration, reading from the
previous event transform or from the process instance.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: fill_momenta => resonant_subprocess_set_fill_momenta
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_fill_momenta (prc_set)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
end subroutine resonant_subprocess_set_fill_momenta
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_fill_momenta (prc_set)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
integer :: i, n
call prc_set%evt%fill_momenta ()
end subroutine resonant_subprocess_set_fill_momenta
@ %def resonant_subprocess_set_fill_momenta
@ Determine the indices of the resonance histories that can be
considered on-shell for the current kinematics.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: determine_on_shell_histories &
=> resonant_subprocess_set_determine_on_shell_histories
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_determine_on_shell_histories &
(prc_set, i_component, index_array)
class(resonant_subprocess_set_t), intent(in) :: prc_set
integer, intent(in) :: i_component
integer, dimension(:), allocatable, intent(out) :: index_array
end subroutine resonant_subprocess_set_determine_on_shell_histories
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_determine_on_shell_histories &
(prc_set, i_component, index_array)
class(resonant_subprocess_set_t), intent(in) :: prc_set
integer, intent(in) :: i_component
integer, dimension(:), allocatable, intent(out) :: index_array
call prc_set%evt%determine_on_shell_histories (index_array)
end subroutine resonant_subprocess_set_determine_on_shell_histories
@ %def resonant_subprocess_set_determine_on_shell_histories
@ Evaluate selected subprocesses. (In actual operation, the ones that
have been tagged as on-shell.)
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: evaluate_subprocess &
=> resonant_subprocess_set_evaluate_subprocess
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_evaluate_subprocess &
(prc_set, index_array)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
integer, dimension(:), intent(in) :: index_array
end subroutine resonant_subprocess_set_evaluate_subprocess
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_evaluate_subprocess &
(prc_set, index_array)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
integer, dimension(:), intent(in) :: index_array
call prc_set%evt%evaluate_subprocess (index_array)
end subroutine resonant_subprocess_set_evaluate_subprocess
@ %def resonant_subprocess_set_evaluate_subprocess
@ Extract the matrix elements of the master process / the resonant
subprocesses. After the previous routine has been executed, they
should be available and stored in the corresponding process instances.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: get_master_sqme &
=> resonant_subprocess_set_get_master_sqme
procedure :: get_subprocess_sqme &
=> resonant_subprocess_set_get_subprocess_sqme
<<Restricted subprocesses: sub interfaces>>=
module function resonant_subprocess_set_get_master_sqme &
(prc_set) result (sqme)
class(resonant_subprocess_set_t), intent(in) :: prc_set
real(default) :: sqme
end function resonant_subprocess_set_get_master_sqme
module subroutine resonant_subprocess_set_get_subprocess_sqme &
(prc_set, sqme)
class(resonant_subprocess_set_t), intent(in) :: prc_set
real(default), dimension(:), intent(inout) :: sqme
end subroutine resonant_subprocess_set_get_subprocess_sqme
<<Restricted subprocesses: procedures>>=
module function resonant_subprocess_set_get_master_sqme &
(prc_set) result (sqme)
class(resonant_subprocess_set_t), intent(in) :: prc_set
real(default) :: sqme
sqme = prc_set%evt%get_master_sqme ()
end function resonant_subprocess_set_get_master_sqme
module subroutine resonant_subprocess_set_get_subprocess_sqme (prc_set, sqme)
class(resonant_subprocess_set_t), intent(in) :: prc_set
real(default), dimension(:), intent(inout) :: sqme
integer :: i
call prc_set%evt%get_subprocess_sqme (sqme)
end subroutine resonant_subprocess_set_get_subprocess_sqme
@ %def resonant_subprocess_set_get_master_sqme
@ %def resonant_subprocess_set_get_subprocess_sqme
@ We use the calculations of resonant matrix elements to determine
probabilities for all resonance configurations.
<<Restricted subprocesses: resonant subprocess set: TBP>>=
procedure :: compute_probabilities &
=> resonant_subprocess_set_compute_probabilities
<<Restricted subprocesses: sub interfaces>>=
module subroutine resonant_subprocess_set_compute_probabilities &
(prc_set, prob_array)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
real(default), dimension(:), allocatable, intent(out) :: prob_array
end subroutine resonant_subprocess_set_compute_probabilities
<<Restricted subprocesses: procedures>>=
module subroutine resonant_subprocess_set_compute_probabilities &
(prc_set, prob_array)
class(resonant_subprocess_set_t), intent(inout) :: prc_set
real(default), dimension(:), allocatable, intent(out) :: prob_array
integer, dimension(:), allocatable :: index_array
real(default) :: sqme, sqme_sum, sqme_bg
real(default), dimension(:), allocatable :: sqme_res
integer :: n
n = size (prc_set%subprocess)
allocate (prob_array (0:n), source = 0._default)
call prc_set%evt%compute_probabilities ()
call prc_set%evt%get_selector_weights (prob_array)
end subroutine resonant_subprocess_set_compute_probabilities
@ %def resonant_subprocess_set_compute_probabilities
@
\subsection{Unit tests}
Test module, followed by the stand-alone unit-test procedures.
<<[[restricted_subprocesses_ut.f90]]>>=
<<File header>>
module restricted_subprocesses_ut
use unit_tests
use restricted_subprocesses_uti
<<Standard module head>>
<<Restricted subprocesses: public test>>
contains
<<Restricted subprocesses: test driver>>
end module restricted_subprocesses_ut
@ %def restricted_subprocesses_ut
@
<<[[restricted_subprocesses_uti.f90]]>>=
<<File header>>
module restricted_subprocesses_uti
<<Use kinds>>
<<Use strings>>
use io_units, only: free_unit
use format_defs, only: FMT_10, FMT_12
use lorentz, only: vector4_t, vector3_moving, vector4_moving
use particle_specifiers, only: new_prt_spec
use process_libraries, only: process_library_t
use resonances, only: resonance_info_t
use resonances, only: resonance_history_t
use resonances, only: resonance_history_set_t
use state_matrices, only: FM_IGNORE_HELICITY
use particles, only: particle_set_t
use model_data, only: model_data_t
use models, only: syntax_model_file_init, syntax_model_file_final
use models, only: model_t
use rng_base_ut, only: rng_test_factory_t
use mci_base, only: mci_t
use phs_base, only: phs_config_t
use phs_forests, only: syntax_phs_forest_init, syntax_phs_forest_final
use phs_wood, only: phs_wood_config_t
use process_libraries, only: process_def_entry_t
use process_libraries, only: process_component_def_t
use prclib_stacks, only: prclib_entry_t
use prc_core_def, only: prc_core_def_t
use prc_omega, only: omega_def_t
use process, only: process_t
use instances, only: process_instance_t
use process_stacks, only: process_entry_t
use event_transforms, only: evt_trivial_t
use resonance_insertion, only: evt_resonance_t
use integrations, only: integrate_process
use rt_data, only: rt_data_t
use restricted_subprocesses
<<Standard module head>>
<<Restricted subprocesses: test declarations>>
<<Restricted subprocesses: test auxiliary types>>
<<Restricted subprocesses: public test auxiliary>>
contains
<<Restricted subprocesses: tests>>
<<Restricted subprocesses: test auxiliary>>
end module restricted_subprocesses_uti
@ %def restricted_subprocesses_uti
@ API: driver for the unit tests below.
<<Restricted subprocesses: public test>>=
public :: restricted_subprocesses_test
<<Restricted subprocesses: test driver>>=
subroutine restricted_subprocesses_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Restricted subprocesses: execute tests>>
end subroutine restricted_subprocesses_test
@ %def restricted_subprocesses_test
@
\subsubsection{subprocess configuration}
Initialize a [[restricted_subprocess_configuration_t]] object which represents
a given process with a defined resonance history.
<<Restricted subprocesses: execute tests>>=
call test (restricted_subprocesses_1, "restricted_subprocesses_1", &
"single subprocess", &
u, results)
<<Restricted subprocesses: test declarations>>=
public :: restricted_subprocesses_1
<<Restricted subprocesses: tests>>=
subroutine restricted_subprocesses_1 (u)
integer, intent(in) :: u
type(rt_data_t) :: global
type(resonance_info_t) :: res_info
type(resonance_history_t) :: res_history
type(string_t) :: prc_name
type(string_t), dimension(2) :: prt_in
type(string_t), dimension(3) :: prt_out
type(restricted_process_configuration_t) :: prc_config
write (u, "(A)") "* Test output: restricted_subprocesses_1"
write (u, "(A)") "* Purpose: create subprocess list from resonances"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%select_model (var_str ("SM"))
write (u, "(A)") "* Create resonance history"
write (u, "(A)")
call res_info%init (3, -24, global%model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
write (u, "(A)")
write (u, "(A)") "* Create process configuration"
write (u, "(A)")
prc_name = "restricted_subprocesses_1_p"
prt_in(1) = "e-"
prt_in(2) = "e+"
prt_out(1) = "d"
prt_out(2) = "u"
prt_out(3) = "W+"
call prc_config%init_resonant_process (prc_name, &
new_prt_spec (prt_in), new_prt_spec (prt_out), &
res_history, global%model, global%var_list)
call prc_config%write (u)
write (u, *)
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: restricted_subprocesses_1"
end subroutine restricted_subprocesses_1
@ %def restricted_subprocesses_1
@
\subsubsection{Subprocess library configuration}
Create a process library that represents restricted subprocesses for a given
set of resonance histories
<<Restricted subprocesses: execute tests>>=
call test (restricted_subprocesses_2, "restricted_subprocesses_2", &
"subprocess library", &
u, results)
<<Restricted subprocesses: test declarations>>=
public :: restricted_subprocesses_2
<<Restricted subprocesses: tests>>=
subroutine restricted_subprocesses_2 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
type(resonance_info_t) :: res_info
type(resonance_history_t), dimension(2) :: res_history
type(resonance_history_set_t) :: res_history_set
type(string_t) :: libname
type(string_t), dimension(2) :: prt_in
type(string_t), dimension(3) :: prt_out
type(resonant_subprocess_set_t) :: prc_set
type(process_library_t), pointer :: lib
logical :: exist
write (u, "(A)") "* Test output: restricted_subprocesses_2"
write (u, "(A)") "* Purpose: create subprocess library from resonances"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%select_model (var_str ("SM"))
write (u, "(A)") "* Create resonance histories"
write (u, "(A)")
call res_info%init (3, -24, global%model, 5)
call res_history(1)%add_resonance (res_info)
call res_history(1)%write (u)
call res_info%init (7, 23, global%model, 5)
call res_history(2)%add_resonance (res_info)
call res_history(2)%write (u)
call res_history_set%init ()
call res_history_set%enter (res_history(1))
call res_history_set%enter (res_history(2))
call res_history_set%freeze ()
write (u, "(A)")
write (u, "(A)") "* Empty restricted subprocess set"
write (u, "(A)")
write (u, "(A,1x,L1)") "active =", prc_set%is_active ()
write (u, "(A)")
call prc_set%write (u, testflag=.true.)
write (u, "(A)")
write (u, "(A)") "* Fill restricted subprocess set"
write (u, "(A)")
libname = "restricted_subprocesses_2_p_R"
prt_in(1) = "e-"
prt_in(2) = "e+"
prt_out(1) = "d"
prt_out(2) = "u"
prt_out(3) = "W+"
call prc_set%init (1)
call prc_set%fill_resonances (res_history_set, 1)
call prc_set%create_library (libname, global, exist)
if (.not. exist) then
call prc_set%add_to_library (1, &
new_prt_spec (prt_in), new_prt_spec (prt_out), &
global)
end if
call prc_set%freeze_library (global)
write (u, "(A,1x,L1)") "active =", prc_set%is_active ()
write (u, "(A)")
call prc_set%write (u, testflag=.true.)
write (u, "(A)")
write (u, "(A)") "* Queries"
write (u, "(A)")
write (u, "(A,1x,I0)") "n_process =", prc_set%get_n_process ()
write (u, "(A)")
write (u, "(A,A,A)") "libname = '", char (prc_set%get_libname ()), "'"
write (u, "(A)")
write (u, "(A,A,A)") "proc_id(1) = '", char (prc_set%get_proc_id (1)), "'"
write (u, "(A,A,A)") "proc_id(2) = '", char (prc_set%get_proc_id (2)), "'"
write (u, "(A)")
write (u, "(A)") "* Process library"
write (u, "(A)")
call prc_set%compile_library (global)
lib => global%prclib_stack%get_library_ptr (libname)
if (associated (lib)) call lib%write (u, libpath=.false.)
write (u, *)
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: restricted_subprocesses_2"
end subroutine restricted_subprocesses_2
@ %def restricted_subprocesses_2
@
\subsubsection{Auxiliary: Test processes}
Auxiliary subroutine that constructs the process library for the above test.
This parallels a similar subroutine in [[processes_uti]], but this time we
want an \oMega\ process.
<<Restricted subprocesses: public test auxiliary>>=
public :: prepare_resonance_test_library
<<Restricted subprocesses: test auxiliary>>=
subroutine prepare_resonance_test_library &
(lib, libname, procname, model, global, u)
type(process_library_t), target, intent(out) :: lib
type(string_t), intent(in) :: libname
type(string_t), intent(in) :: procname
class(model_data_t), intent(in), pointer :: model
type(rt_data_t), intent(in), target :: global
integer, intent(in) :: u
type(string_t), dimension(:), allocatable :: prt_in, prt_out
class(prc_core_def_t), allocatable :: def
type(process_def_entry_t), pointer :: entry
call lib%init (libname)
allocate (prt_in (2), prt_out (3))
prt_in = [var_str ("e+"), var_str ("e-")]
prt_out = [var_str ("d"), var_str ("ubar"), var_str ("W+")]
allocate (omega_def_t :: def)
select type (def)
type is (omega_def_t)
call def%init (model%get_name (), prt_in, prt_out, &
ovm=.false., ufo=.false.)
end select
allocate (entry)
call entry%init (procname, &
model_name = model%get_name (), &
n_in = 2, n_components = 1, &
requires_resonances = .true.)
call entry%import_component (1, n_out = size (prt_out), &
prt_in = new_prt_spec (prt_in), &
prt_out = new_prt_spec (prt_out), &
method = var_str ("omega"), &
variant = def)
call entry%write (u)
call lib%append (entry)
call lib%configure (global%os_data)
call lib%write_makefile (global%os_data, force = .true., verbose = .false.)
call lib%clean (global%os_data, distclean = .false.)
call lib%write_driver (force = .true.)
call lib%load (global%os_data)
end subroutine prepare_resonance_test_library
@ %def prepare_resonance_test_library
@
\subsubsection{Kinematics and resonance selection}
Prepare an actual process with resonant subprocesses. Insert
kinematics and apply the resonance selector in an associated event
transform.
<<Restricted subprocesses: execute tests>>=
call test (restricted_subprocesses_3, "restricted_subprocesses_3", &
"resonance kinematics and probability", &
u, results)
<<Restricted subprocesses: test declarations>>=
public :: restricted_subprocesses_3
<<Restricted subprocesses: tests>>=
subroutine restricted_subprocesses_3 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
class(model_t), pointer :: model
class(model_data_t), pointer :: model_data
type(string_t) :: libname, libname_res
type(string_t) :: procname
type(process_component_def_t), pointer :: process_component_def
type(prclib_entry_t), pointer :: lib_entry
type(process_library_t), pointer :: lib
logical :: exist
type(process_t), pointer :: process
type(process_instance_t), target :: process_instance
type(resonance_history_set_t), dimension(1) :: res_history_set
type(resonant_subprocess_set_t) :: prc_set
type(particle_set_t) :: pset
real(default) :: sqrts, mw, pp
real(default), dimension(3) :: p3
type(vector4_t), dimension(:), allocatable :: p
real(default), dimension(:), allocatable :: m
integer, dimension(:), allocatable :: pdg
real(default), dimension(:), allocatable :: sqme
logical, dimension(:), allocatable :: mask
real(default) :: on_shell_limit
integer, dimension(:), allocatable :: i_array
real(default), dimension(:), allocatable :: prob_array
type(evt_resonance_t), target :: evt_resonance
integer :: i, u_dump
write (u, "(A)") "* Test output: restricted_subprocesses_3"
write (u, "(A)") "* Purpose: handle process and resonance kinematics"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_phs_forest_init ()
call global%global_init ()
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%set_log (var_str ("?resonance_history"), &
.true., is_known = .true.)
call global%select_model (var_str ("SM"))
allocate (model)
call model%init_instance (global%model)
model_data => model
libname = "restricted_subprocesses_3_lib"
libname_res = "restricted_subprocesses_3_lib_res"
procname = "restricted_subprocesses_3_p"
write (u, "(A)") "* Initialize process library and process"
write (u, "(A)")
allocate (lib_entry)
call lib_entry%init (libname)
lib => lib_entry%process_library_t
call global%add_prclib (lib_entry)
call prepare_resonance_test_library &
(lib, libname, procname, model_data, global, u)
call integrate_process (procname, global, &
local_stack = .true., init_only = .true.)
process => global%process_stack%get_process_ptr (procname)
call process_instance%init (process)
call process_instance%setup_event_data ()
write (u, "(A)")
write (u, "(A)") "* Extract resonance history set"
write (u, "(A)")
call process%extract_resonance_history_set &
(res_history_set(1), include_trivial=.true., i_component=1)
call res_history_set(1)%write (u)
write (u, "(A)")
write (u, "(A)") "* Build resonant-subprocess library"
write (u, "(A)")
call prc_set%init (1)
call prc_set%fill_resonances (res_history_set(1), 1)
process_component_def => process%get_component_def_ptr (1)
call prc_set%create_library (libname_res, global, exist)
if (.not. exist) then
call prc_set%add_to_library (1, &
process_component_def%get_prt_spec_in (), &
process_component_def%get_prt_spec_out (), &
global)
end if
call prc_set%freeze_library (global)
call prc_set%compile_library (global)
call prc_set%write (u, testflag=.true.)
write (u, "(A)")
write (u, "(A)") "* Build particle set"
write (u, "(A)")
sqrts = global%get_rval (var_str ("sqrts"))
mw = 80._default ! deliberately slightly different from true mw
pp = sqrt (sqrts**2 - 4 * mw**2) / 2
allocate (pdg (5), p (5), m (5))
pdg(1) = -11
p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
m(1) = 0
pdg(2) = 11
p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
m(2) = 0
pdg(3) = 1
p3(1) = pp/2
p3(2) = mw/2
p3(3) = 0
p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
m(3) = 0
p3(2) = -mw/2
pdg(4) = -2
p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
m(4) = 0
pdg(5) = 24
p(5) = vector4_moving (sqrts/2,-pp, 1)
m(5) = mw
call pset%init_direct (0, 2, 0, 0, 3, pdg, model)
call pset%set_momentum (p, m**2)
call pset%write (u, testflag=.true.)
write (u, "(A)")
write (u, "(A)") "* Fill process instance"
! workflow from event_recalculate
call process_instance%choose_mci (1)
call process_instance%set_trace (pset, 1)
call process_instance%recover &
(1, 1, update_sqme=.true., recover_phs=.false.)
call process_instance%evaluate_event_data (weight = 1._default)
write (u, "(A)")
write (u, "(A)") "* Prepare resonant subprocesses"
call prc_set%prepare_process_objects (global)
call prc_set%prepare_process_instances (global)
call evt_resonance%set_resonance_data (res_history_set)
call evt_resonance%select_component (1)
call prc_set%connect_transform (evt_resonance)
call evt_resonance%connect (process_instance, model)
call prc_set%fill_momenta ()
write (u, "(A)")
write (u, "(A)") "* Show squared matrix element of master process,"
write (u, "(A)") " should coincide with 2nd subprocess sqme"
write (u, "(A)")
write (u, "(1x,I0,1x," // FMT_12 // ")") 0, prc_set%get_master_sqme ()
write (u, "(A)")
write (u, "(A)") "* Compute squared matrix elements &
&of selected resonant subprocesses [1,2]"
write (u, "(A)")
call prc_set%evaluate_subprocess ([1,2])
allocate (sqme (3), source = 0._default)
call prc_set%get_subprocess_sqme (sqme)
do i = 1, size (sqme)
write (u, "(1x,I0,1x," // FMT_12 // ")") i, sqme(i)
end do
deallocate (sqme)
write (u, "(A)")
write (u, "(A)") "* Compute squared matrix elements &
&of all resonant subprocesses"
write (u, "(A)")
call prc_set%evaluate_subprocess ([1,2,3])
allocate (sqme (3), source = 0._default)
call prc_set%get_subprocess_sqme (sqme)
do i = 1, size (sqme)
write (u, "(1x,I0,1x," // FMT_12 // ")") i, sqme(i)
end do
deallocate (sqme)
write (u, "(A)")
write (u, "(A)") "* Write process instances to file &
&restricted_subprocesses_3_lib_res.dat"
u_dump = free_unit ()
open (unit = u_dump, file = "restricted_subprocesses_3_lib_res.dat", &
action = "write", status = "replace")
call prc_set%dump_instances (u_dump)
close (u_dump)
write (u, "(A)")
write (u, "(A)") "* Determine on-shell resonant subprocesses"
write (u, "(A)")
on_shell_limit = 0
write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
call prc_set%set_on_shell_limit (on_shell_limit)
call prc_set%determine_on_shell_histories (1, i_array)
write (u, "(1x,A,9(1x,I0))") "resonant =", i_array
on_shell_limit = 0.1_default
write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
call prc_set%set_on_shell_limit (on_shell_limit)
call prc_set%determine_on_shell_histories (1, i_array)
write (u, "(1x,A,9(1x,I0))") "resonant =", i_array
on_shell_limit = 10._default
write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
call prc_set%set_on_shell_limit (on_shell_limit)
call prc_set%determine_on_shell_histories (1, i_array)
write (u, "(1x,A,9(1x,I0))") "resonant =", i_array
on_shell_limit = 10000._default
write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
call prc_set%set_on_shell_limit (on_shell_limit)
call prc_set%determine_on_shell_histories (1, i_array)
write (u, "(1x,A,9(1x,I0))") "resonant =", i_array
write (u, "(A)")
write (u, "(A)") "* Compute probabilities for applicable resonances"
write (u, "(A)") " and initialize the process selector"
write (u, "(A)") " (The first number is the probability for background)"
write (u, "(A)")
on_shell_limit = 0
write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
call prc_set%set_on_shell_limit (on_shell_limit)
call prc_set%determine_on_shell_histories (1, i_array)
call prc_set%compute_probabilities (prob_array)
write (u, "(1x,A,9(1x,"// FMT_12 // "))") "resonant =", prob_array
call prc_set%write (u, testflag=.true.)
write (u, *)
on_shell_limit = 10._default
write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
call prc_set%set_on_shell_limit (on_shell_limit)
call prc_set%determine_on_shell_histories (1, i_array)
call prc_set%compute_probabilities (prob_array)
write (u, "(1x,A,9(1x,"// FMT_12 // "))") "resonant =", prob_array
call prc_set%write (u, testflag=.true.)
write (u, *)
on_shell_limit = 10000._default
write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
call prc_set%set_on_shell_limit (on_shell_limit)
call prc_set%determine_on_shell_histories (1, i_array)
call prc_set%compute_probabilities (prob_array)
write (u, "(1x,A,9(1x,"// FMT_12 // "))") "resonant =", prob_array
write (u, *)
call prc_set%write (u, testflag=.true.)
write (u, *)
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_phs_forest_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: restricted_subprocesses_3"
end subroutine restricted_subprocesses_3
@ %def restricted_subprocesses_3
@
\subsubsection{Event transform}
Prepare an actual process with resonant subprocesses. Prepare the
resonance selector for a fixed event and apply the resonance-insertion
event transform.
<<Restricted subprocesses: execute tests>>=
call test (restricted_subprocesses_4, "restricted_subprocesses_4", &
"event transform", &
u, results)
<<Restricted subprocesses: test declarations>>=
public :: restricted_subprocesses_4
<<Restricted subprocesses: tests>>=
subroutine restricted_subprocesses_4 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
class(model_t), pointer :: model
class(model_data_t), pointer :: model_data
type(string_t) :: libname, libname_res
type(string_t) :: procname
type(process_component_def_t), pointer :: process_component_def
type(prclib_entry_t), pointer :: lib_entry
type(process_library_t), pointer :: lib
logical :: exist
type(process_t), pointer :: process
type(process_instance_t), target :: process_instance
type(resonance_history_set_t), dimension(1) :: res_history_set
type(resonant_subprocess_set_t) :: prc_set
type(particle_set_t) :: pset
real(default) :: sqrts, mw, pp
real(default), dimension(3) :: p3
type(vector4_t), dimension(:), allocatable :: p
real(default), dimension(:), allocatable :: m
integer, dimension(:), allocatable :: pdg
real(default) :: on_shell_limit
type(evt_trivial_t), target :: evt_trivial
type(evt_resonance_t), target :: evt_resonance
real(default) :: probability
integer :: i
write (u, "(A)") "* Test output: restricted_subprocesses_4"
write (u, "(A)") "* Purpose: employ event transform"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_phs_forest_init ()
call global%global_init ()
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%set_log (var_str ("?resonance_history"), &
.true., is_known = .true.)
call global%select_model (var_str ("SM"))
allocate (model)
call model%init_instance (global%model)
model_data => model
libname = "restricted_subprocesses_4_lib"
libname_res = "restricted_subprocesses_4_lib_res"
procname = "restricted_subprocesses_4_p"
write (u, "(A)") "* Initialize process library and process"
write (u, "(A)")
allocate (lib_entry)
call lib_entry%init (libname)
lib => lib_entry%process_library_t
call global%add_prclib (lib_entry)
call prepare_resonance_test_library &
(lib, libname, procname, model_data, global, u)
call integrate_process (procname, global, &
local_stack = .true., init_only = .true.)
process => global%process_stack%get_process_ptr (procname)
call process_instance%init (process)
call process_instance%setup_event_data ()
write (u, "(A)")
write (u, "(A)") "* Extract resonance history set"
call process%extract_resonance_history_set &
(res_history_set(1), include_trivial=.false., i_component=1)
write (u, "(A)")
write (u, "(A)") "* Build resonant-subprocess library"
call prc_set%init (1)
call prc_set%fill_resonances (res_history_set(1), 1)
process_component_def => process%get_component_def_ptr (1)
call prc_set%create_library (libname_res, global, exist)
if (.not. exist) then
call prc_set%add_to_library (1, &
process_component_def%get_prt_spec_in (), &
process_component_def%get_prt_spec_out (), &
global)
end if
call prc_set%freeze_library (global)
call prc_set%compile_library (global)
write (u, "(A)")
write (u, "(A)") "* Build particle set"
write (u, "(A)")
sqrts = global%get_rval (var_str ("sqrts"))
mw = 80._default ! deliberately slightly different from true mw
pp = sqrt (sqrts**2 - 4 * mw**2) / 2
allocate (pdg (5), p (5), m (5))
pdg(1) = -11
p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
m(1) = 0
pdg(2) = 11
p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
m(2) = 0
pdg(3) = 1
p3(1) = pp/2
p3(2) = mw/2
p3(3) = 0
p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
m(3) = 0
p3(2) = -mw/2
pdg(4) = -2
p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
m(4) = 0
pdg(5) = 24
p(5) = vector4_moving (sqrts/2,-pp, 1)
m(5) = mw
call pset%init_direct (0, 2, 0, 0, 3, pdg, model)
call pset%set_momentum (p, m**2)
write (u, "(A)") "* Fill process instance"
write (u, "(A)")
! workflow from event_recalculate
call process_instance%choose_mci (1)
call process_instance%set_trace (pset, 1)
call process_instance%recover &
(1, 1, update_sqme=.true., recover_phs=.false.)
call process_instance%evaluate_event_data (weight = 1._default)
write (u, "(A)") "* Prepare resonant subprocesses"
write (u, "(A)")
call prc_set%prepare_process_objects (global)
call prc_set%prepare_process_instances (global)
write (u, "(A)") "* Fill trivial event transform (deliberately w/o color)"
write (u, "(A)")
call evt_trivial%connect (process_instance, model)
call evt_trivial%set_particle_set (pset, 1, 1)
call evt_trivial%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize resonance-insertion event transform"
write (u, "(A)")
evt_trivial%next => evt_resonance
evt_resonance%previous => evt_trivial
call evt_resonance%set_resonance_data (res_history_set)
call evt_resonance%select_component (1)
call evt_resonance%connect (process_instance, model)
call prc_set%connect_transform (evt_resonance)
call evt_resonance%write (u)
write (u, "(A)")
write (u, "(A)") "* Compute probabilities for applicable resonances"
write (u, "(A)") " and initialize the process selector"
write (u, "(A)")
on_shell_limit = 10._default
write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
call evt_resonance%set_on_shell_limit (on_shell_limit)
write (u, "(A)")
write (u, "(A)") "* Evaluate resonance-insertion event transform"
write (u, "(A)")
call evt_resonance%prepare_new_event (1, 1)
call evt_resonance%generate_weighted (probability)
call evt_resonance%make_particle_set (1, .false.)
call evt_resonance%write (u, testflag=.true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_phs_forest_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: restricted_subprocesses_4"
end subroutine restricted_subprocesses_4
@ %def restricted_subprocesses_4
@
\subsubsection{Gaussian turnoff}
Identical to the previous process, except that we apply a Gaussian
turnoff to the resonance kinematics, which affects the subprocess selector.
<<Restricted subprocesses: execute tests>>=
call test (restricted_subprocesses_5, "restricted_subprocesses_5", &
"event transform with gaussian turnoff", &
u, results)
<<Restricted subprocesses: test declarations>>=
public :: restricted_subprocesses_5
<<Restricted subprocesses: tests>>=
subroutine restricted_subprocesses_5 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
class(model_t), pointer :: model
class(model_data_t), pointer :: model_data
type(string_t) :: libname, libname_res
type(string_t) :: procname
type(process_component_def_t), pointer :: process_component_def
type(prclib_entry_t), pointer :: lib_entry
type(process_library_t), pointer :: lib
logical :: exist
type(process_t), pointer :: process
type(process_instance_t), target :: process_instance
type(resonance_history_set_t), dimension(1) :: res_history_set
type(resonant_subprocess_set_t) :: prc_set
type(particle_set_t) :: pset
real(default) :: sqrts, mw, pp
real(default), dimension(3) :: p3
type(vector4_t), dimension(:), allocatable :: p
real(default), dimension(:), allocatable :: m
integer, dimension(:), allocatable :: pdg
real(default) :: on_shell_limit
real(default) :: on_shell_turnoff
type(evt_trivial_t), target :: evt_trivial
type(evt_resonance_t), target :: evt_resonance
real(default) :: probability
integer :: i
write (u, "(A)") "* Test output: restricted_subprocesses_5"
write (u, "(A)") "* Purpose: employ event transform &
&with gaussian turnoff"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_phs_forest_init ()
call global%global_init ()
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%set_log (var_str ("?resonance_history"), &
.true., is_known = .true.)
call global%select_model (var_str ("SM"))
allocate (model)
call model%init_instance (global%model)
model_data => model
libname = "restricted_subprocesses_5_lib"
libname_res = "restricted_subprocesses_5_lib_res"
procname = "restricted_subprocesses_5_p"
write (u, "(A)") "* Initialize process library and process"
write (u, "(A)")
allocate (lib_entry)
call lib_entry%init (libname)
lib => lib_entry%process_library_t
call global%add_prclib (lib_entry)
call prepare_resonance_test_library &
(lib, libname, procname, model_data, global, u)
call integrate_process (procname, global, &
local_stack = .true., init_only = .true.)
process => global%process_stack%get_process_ptr (procname)
call process_instance%init (process)
call process_instance%setup_event_data ()
write (u, "(A)")
write (u, "(A)") "* Extract resonance history set"
call process%extract_resonance_history_set &
(res_history_set(1), include_trivial=.false., i_component=1)
write (u, "(A)")
write (u, "(A)") "* Build resonant-subprocess library"
call prc_set%init (1)
call prc_set%fill_resonances (res_history_set(1), 1)
process_component_def => process%get_component_def_ptr (1)
call prc_set%create_library (libname_res, global, exist)
if (.not. exist) then
call prc_set%add_to_library (1, &
process_component_def%get_prt_spec_in (), &
process_component_def%get_prt_spec_out (), &
global)
end if
call prc_set%freeze_library (global)
call prc_set%compile_library (global)
write (u, "(A)")
write (u, "(A)") "* Build particle set"
write (u, "(A)")
sqrts = global%get_rval (var_str ("sqrts"))
mw = 80._default ! deliberately slightly different from true mw
pp = sqrt (sqrts**2 - 4 * mw**2) / 2
allocate (pdg (5), p (5), m (5))
pdg(1) = -11
p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
m(1) = 0
pdg(2) = 11
p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
m(2) = 0
pdg(3) = 1
p3(1) = pp/2
p3(2) = mw/2
p3(3) = 0
p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
m(3) = 0
p3(2) = -mw/2
pdg(4) = -2
p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
m(4) = 0
pdg(5) = 24
p(5) = vector4_moving (sqrts/2,-pp, 1)
m(5) = mw
call pset%init_direct (0, 2, 0, 0, 3, pdg, model)
call pset%set_momentum (p, m**2)
write (u, "(A)") "* Fill process instance"
write (u, "(A)")
! workflow from event_recalculate
call process_instance%choose_mci (1)
call process_instance%set_trace (pset, 1)
call process_instance%recover &
(1, 1, update_sqme=.true., recover_phs=.false.)
call process_instance%evaluate_event_data (weight = 1._default)
write (u, "(A)") "* Prepare resonant subprocesses"
write (u, "(A)")
call prc_set%prepare_process_objects (global)
call prc_set%prepare_process_instances (global)
write (u, "(A)") "* Fill trivial event transform (deliberately w/o color)"
write (u, "(A)")
call evt_trivial%connect (process_instance, model)
call evt_trivial%set_particle_set (pset, 1, 1)
call evt_trivial%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize resonance-insertion event transform"
write (u, "(A)")
evt_trivial%next => evt_resonance
evt_resonance%previous => evt_trivial
call evt_resonance%set_resonance_data (res_history_set)
call evt_resonance%select_component (1)
call evt_resonance%connect (process_instance, model)
call prc_set%connect_transform (evt_resonance)
call evt_resonance%write (u)
write (u, "(A)")
write (u, "(A)") "* Compute probabilities for applicable resonances"
write (u, "(A)") " and initialize the process selector"
write (u, "(A)")
on_shell_limit = 10._default
write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", &
on_shell_limit
call evt_resonance%set_on_shell_limit (on_shell_limit)
on_shell_turnoff = 1._default
write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_turnoff =", &
on_shell_turnoff
call evt_resonance%set_on_shell_turnoff (on_shell_turnoff)
write (u, "(A)")
write (u, "(A)") "* Evaluate resonance-insertion event transform"
write (u, "(A)")
call evt_resonance%prepare_new_event (1, 1)
call evt_resonance%generate_weighted (probability)
call evt_resonance%make_particle_set (1, .false.)
call evt_resonance%write (u, testflag=.true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_phs_forest_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: restricted_subprocesses_5"
end subroutine restricted_subprocesses_5
@ %def restricted_subprocesses_5
@
\subsubsection{Event transform}
The same process and event again. This time, switch off the background
contribution, so the selector becomes trivial.
<<Restricted subprocesses: execute tests>>=
call test (restricted_subprocesses_6, "restricted_subprocesses_6", &
"event transform with background switched off", &
u, results)
<<Restricted subprocesses: test declarations>>=
public :: restricted_subprocesses_6
<<Restricted subprocesses: tests>>=
subroutine restricted_subprocesses_6 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
class(model_t), pointer :: model
class(model_data_t), pointer :: model_data
type(string_t) :: libname, libname_res
type(string_t) :: procname
type(process_component_def_t), pointer :: process_component_def
type(prclib_entry_t), pointer :: lib_entry
type(process_library_t), pointer :: lib
logical :: exist
type(process_t), pointer :: process
type(process_instance_t), target :: process_instance
type(resonance_history_set_t), dimension(1) :: res_history_set
type(resonant_subprocess_set_t) :: prc_set
type(particle_set_t) :: pset
real(default) :: sqrts, mw, pp
real(default), dimension(3) :: p3
type(vector4_t), dimension(:), allocatable :: p
real(default), dimension(:), allocatable :: m
integer, dimension(:), allocatable :: pdg
real(default) :: on_shell_limit
real(default) :: background_factor
type(evt_trivial_t), target :: evt_trivial
type(evt_resonance_t), target :: evt_resonance
real(default) :: probability
integer :: i
write (u, "(A)") "* Test output: restricted_subprocesses_6"
write (u, "(A)") "* Purpose: employ event transform &
&with background switched off"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_phs_forest_init ()
call global%global_init ()
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%set_log (var_str ("?resonance_history"), &
.true., is_known = .true.)
call global%select_model (var_str ("SM"))
allocate (model)
call model%init_instance (global%model)
model_data => model
libname = "restricted_subprocesses_6_lib"
libname_res = "restricted_subprocesses_6_lib_res"
procname = "restricted_subprocesses_6_p"
write (u, "(A)") "* Initialize process library and process"
write (u, "(A)")
allocate (lib_entry)
call lib_entry%init (libname)
lib => lib_entry%process_library_t
call global%add_prclib (lib_entry)
call prepare_resonance_test_library &
(lib, libname, procname, model_data, global, u)
call integrate_process (procname, global, &
local_stack = .true., init_only = .true.)
process => global%process_stack%get_process_ptr (procname)
call process_instance%init (process)
call process_instance%setup_event_data ()
write (u, "(A)")
write (u, "(A)") "* Extract resonance history set"
call process%extract_resonance_history_set &
(res_history_set(1), include_trivial=.false., i_component=1)
write (u, "(A)")
write (u, "(A)") "* Build resonant-subprocess library"
call prc_set%init (1)
call prc_set%fill_resonances (res_history_set(1), 1)
process_component_def => process%get_component_def_ptr (1)
call prc_set%create_library (libname_res, global, exist)
if (.not. exist) then
call prc_set%add_to_library (1, &
process_component_def%get_prt_spec_in (), &
process_component_def%get_prt_spec_out (), &
global)
end if
call prc_set%freeze_library (global)
call prc_set%compile_library (global)
write (u, "(A)")
write (u, "(A)") "* Build particle set"
write (u, "(A)")
sqrts = global%get_rval (var_str ("sqrts"))
mw = 80._default ! deliberately slightly different from true mw
pp = sqrt (sqrts**2 - 4 * mw**2) / 2
allocate (pdg (5), p (5), m (5))
pdg(1) = -11
p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
m(1) = 0
pdg(2) = 11
p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
m(2) = 0
pdg(3) = 1
p3(1) = pp/2
p3(2) = mw/2
p3(3) = 0
p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
m(3) = 0
p3(2) = -mw/2
pdg(4) = -2
p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
m(4) = 0
pdg(5) = 24
p(5) = vector4_moving (sqrts/2,-pp, 1)
m(5) = mw
call pset%init_direct (0, 2, 0, 0, 3, pdg, model)
call pset%set_momentum (p, m**2)
write (u, "(A)") "* Fill process instance"
write (u, "(A)")
! workflow from event_recalculate
call process_instance%choose_mci (1)
call process_instance%set_trace (pset, 1)
call process_instance%recover &
(1, 1, update_sqme=.true., recover_phs=.false.)
call process_instance%evaluate_event_data (weight = 1._default)
write (u, "(A)") "* Prepare resonant subprocesses"
write (u, "(A)")
call prc_set%prepare_process_objects (global)
call prc_set%prepare_process_instances (global)
write (u, "(A)") "* Fill trivial event transform (deliberately w/o color)"
write (u, "(A)")
call evt_trivial%connect (process_instance, model)
call evt_trivial%set_particle_set (pset, 1, 1)
call evt_trivial%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize resonance-insertion event transform"
write (u, "(A)")
evt_trivial%next => evt_resonance
evt_resonance%previous => evt_trivial
call evt_resonance%set_resonance_data (res_history_set)
call evt_resonance%select_component (1)
call evt_resonance%connect (process_instance, model)
call prc_set%connect_transform (evt_resonance)
call evt_resonance%write (u)
write (u, "(A)")
write (u, "(A)") "* Compute probabilities for applicable resonances"
write (u, "(A)") " and initialize the process selector"
write (u, "(A)")
on_shell_limit = 10._default
write (u, "(1x,A,1x," // FMT_10 // ")") &
"on_shell_limit =", on_shell_limit
call evt_resonance%set_on_shell_limit (on_shell_limit)
background_factor = 0
write (u, "(1x,A,1x," // FMT_10 // ")") &
"background_factor =", background_factor
call evt_resonance%set_background_factor (background_factor)
write (u, "(A)")
write (u, "(A)") "* Evaluate resonance-insertion event transform"
write (u, "(A)")
call evt_resonance%prepare_new_event (1, 1)
call evt_resonance%generate_weighted (probability)
call evt_resonance%make_particle_set (1, .false.)
call evt_resonance%write (u, testflag=.true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
call syntax_phs_forest_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: restricted_subprocesses_6"
end subroutine restricted_subprocesses_6
@ %def restricted_subprocesses_6
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Simulation}
This module manages simulation: event generation and reading/writing of event
files. The [[simulation]] object is intended to be used (via a pointer)
outside of \whizard, if events are generated individually by an external
driver.
<<[[simulations.f90]]>>=
<<File header>>
module simulations
<<Use mpi f08>>
<<Use kinds>>
<<Use strings>>
use sm_qcd
use model_data
use particles
use rng_base
use selectors
use process_libraries, only: process_library_t
use process_libraries, only: process_component_def_t
use prc_core
use process
use event_base
use event_handles, only: event_handle_t
use events
use event_transforms
use eio_data
use eio_base
use rt_data
use event_streams
use restricted_subprocesses, only: resonant_subprocess_set_t
use restricted_subprocesses, only: get_libname_res
<<Standard module head>>
<<Simulations: public>>
<<Simulations: types>>
<<Simulations: interfaces>>
interface
<<Simulations: sub interfaces>>
end interface
end module simulations
@ %def simulations
@
<<[[simulations_sub.f90]]>>=
<<File header>>
submodule (simulations) simulations_s
<<Use mpi f08>>
<<Use debug>>
use io_units
use format_utils, only: write_separator
use format_defs, only: FMT_15, FMT_19
use numeric_utils
use string_utils, only: str
use diagnostics
use os_interface
use md5
use variables, only: var_list_t
use eval_trees
use flavors
use state_matrices, only: FM_IGNORE_HELICITY
use beam_structures, only: beam_structure_t
use beams
use rng_stream, only: rng_stream_t
use resonances, only: resonance_history_set_t
! TODO: (bcn 2016-09-13) should be ideally only pcm_base
use pcm, only: pcm_nlo_t, pcm_nlo_workspace_t
! TODO: (bcn 2016-09-13) details of process config should not be necessary here
- use process_config, only: COMP_REAL_FIN
+ use process_config, only: COMP_REAL_FIN, COMP_MASTER, COMP_REAL, &
+ COMP_REAL_SING
use instances
use shower
use evt_nlo
use dispatch_beams, only: dispatch_qcd
use dispatch_rng, only: dispatch_rng_factory
use dispatch_rng, only: update_rng_seed_in_var_list
use dispatch_me_methods, only: dispatch_core_update, dispatch_core_restore
use dispatch_transforms, only: dispatch_evt_isr_epa_handler
use dispatch_transforms, only: dispatch_evt_resonance
use dispatch_transforms, only: dispatch_evt_decay
use dispatch_transforms, only: dispatch_evt_shower
use dispatch_transforms, only: dispatch_evt_hadrons
use dispatch_transforms, only: dispatch_evt_nlo
use integrations
implicit none
contains
<<Simulations: procedures>>
end submodule simulations_s
@ %def simulations_s
@
\subsection{Event counting}
In this object we collect statistical information about an event
sample or sub-sample.
<<Simulations: types>>=
type :: counter_t
integer :: total = 0
integer :: generated = 0
integer :: read = 0
integer :: positive = 0
integer :: negative = 0
integer :: zero = 0
integer :: excess = 0
integer :: dropped = 0
real(default) :: max_excess = 0
real(default) :: sum_excess = 0
logical :: reproduce_xsection = .false.
real(default) :: mean = 0
real(default) :: varsq = 0
integer :: nlo_weight_counter = 0
contains
<<Simulations: counter: TBP>>
end type counter_t
@ %def simulation_counter_t
@ Output.
<<Simulations: counter: TBP>>=
procedure :: write => counter_write
<<Simulations: sub interfaces>>=
module subroutine counter_write (counter, unit)
class(counter_t), intent(in) :: counter
integer, intent(in), optional :: unit
end subroutine counter_write
<<Simulations: procedures>>=
module subroutine counter_write (counter, unit)
class(counter_t), intent(in) :: counter
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
1 format (3x,A,I0)
2 format (5x,A,I0)
3 format (5x,A,ES19.12)
write (u, 1) "Events total = ", counter%total
write (u, 2) "generated = ", counter%generated
write (u, 2) "read = ", counter%read
write (u, 2) "positive weight = ", counter%positive
write (u, 2) "negative weight = ", counter%negative
write (u, 2) "zero weight = ", counter%zero
write (u, 2) "excess weight = ", counter%excess
if (counter%excess /= 0) then
write (u, 3) "max excess = ", counter%max_excess
write (u, 3) "avg excess = ", counter%sum_excess / counter%total
end if
write (u, 1) "Events dropped = ", counter%dropped
end subroutine counter_write
@ %def counter_write
@ This is a screen message: if there was an excess, display statistics.
<<Simulations: counter: TBP>>=
procedure :: show_excess => counter_show_excess
<<Simulations: sub interfaces>>=
module subroutine counter_show_excess (counter)
class(counter_t), intent(in) :: counter
end subroutine counter_show_excess
<<Simulations: procedures>>=
module subroutine counter_show_excess (counter)
class(counter_t), intent(in) :: counter
if (counter%excess > 0) then
write (msg_buffer, "(A,1x,I0,1x,A,1x,'(',F7.3,' %)')") &
"Encountered events with excess weight:", counter%excess, &
"events", 100 * counter%excess / real (counter%total)
call msg_warning ()
write (msg_buffer, "(A,ES10.3)") &
"Maximum excess weight =", counter%max_excess
call msg_message ()
write (msg_buffer, "(A,ES10.3)") &
"Average excess weight =", counter%sum_excess / counter%total
call msg_message ()
end if
end subroutine counter_show_excess
@ %def counter_show_excess
@ If events have been dropped during simulation of weighted events,
issue a message here.
If a fraction [[n_dropped / n_total]] of the events fail the cuts, we keep
generating new ones until we have [[n_total]] events with [[weight > 0]].
Thus, the total sum of weights will be a fraction of [[n_dropped / n_total]]
too large. However, we do not know how many events will pass or fail the cuts
prior to generating them so we leave it to the user to correct for this factor.
<<Simulations: counter: TBP>>=
procedure :: show_dropped => counter_show_dropped
<<Simulations: sub interfaces>>=
module subroutine counter_show_dropped (counter)
class(counter_t), intent(in) :: counter
end subroutine counter_show_dropped
<<Simulations: procedures>>=
module subroutine counter_show_dropped (counter)
class(counter_t), intent(in) :: counter
if (counter%dropped > 0) then
write (msg_buffer, "(A,1x,I0,1x,'(',A,1x,I0,')')") &
"Dropped events (weight zero) =", &
counter%dropped, "total", counter%dropped + counter%total
call msg_message ()
write (msg_buffer, "(A,ES15.8)") &
"All event weights must be rescaled by f =", &
real (counter%total, default) &
/ real (counter%dropped + counter%total, default)
call msg_warning ()
end if
end subroutine counter_show_dropped
@ %def counter_show_dropped
@
<<Simulations: counter: TBP>>=
procedure :: show_mean_and_variance => counter_show_mean_and_variance
<<Simulations: sub interfaces>>=
module subroutine counter_show_mean_and_variance (counter)
class(counter_t), intent(in) :: counter
end subroutine counter_show_mean_and_variance
<<Simulations: procedures>>=
module subroutine counter_show_mean_and_variance (counter)
class(counter_t), intent(in) :: counter
if (counter%reproduce_xsection .and. counter%nlo_weight_counter > 1) then
print *, "Reconstructed cross-section from event weights: "
print *, counter%mean, '+-', &
sqrt (counter%varsq / (counter%nlo_weight_counter - 1))
end if
end subroutine counter_show_mean_and_variance
@ %def counter_show_mean_and_variance
@ Count an event. The weight and event source are optional; by
default we assume that the event has been generated and has positive
weight.
The optional integer [[n_dropped]] counts weighted events with weight
zero that were encountered while generating the current event, but
dropped (because of their zero weight). Accumulating this number
allows for renormalizing event weight sums in histograms, after the
generation step has been completed.
<<Simulations: counter: TBP>>=
procedure :: record => counter_record
<<Simulations: sub interfaces>>=
module subroutine counter_record &
(counter, weight, excess, n_dropped, from_file)
class(counter_t), intent(inout) :: counter
real(default), intent(in), optional :: weight, excess
integer, intent(in), optional :: n_dropped
logical, intent(in), optional :: from_file
end subroutine counter_record
<<Simulations: procedures>>=
module subroutine counter_record &
(counter, weight, excess, n_dropped, from_file)
class(counter_t), intent(inout) :: counter
real(default), intent(in), optional :: weight, excess
integer, intent(in), optional :: n_dropped
logical, intent(in), optional :: from_file
counter%total = counter%total + 1
if (present (from_file)) then
if (from_file) then
counter%read = counter%read + 1
else
counter%generated = counter%generated + 1
end if
else
counter%generated = counter%generated + 1
end if
if (present (weight)) then
if (weight > 0) then
counter%positive = counter%positive + 1
else if (weight < 0) then
counter%negative = counter%negative + 1
else
counter%zero = counter%zero + 1
end if
else
counter%positive = counter%positive + 1
end if
if (present (excess)) then
if (excess > 0) then
counter%excess = counter%excess + 1
counter%max_excess = max (counter%max_excess, excess)
counter%sum_excess = counter%sum_excess + excess
end if
end if
if (present (n_dropped)) then
counter%dropped = counter%dropped + n_dropped
end if
end subroutine counter_record
@ %def counter_record
<<MPI: Simulations: counter: TBP>>=
procedure :: allreduce_record => counter_allreduce_record
<<MPI: Simulations: sub interfaces>>=
module subroutine counter_allreduce_record (counter)
class(counter_t), intent(inout) :: counter
end subroutine counter_allreduce_record
<<MPI: Simulations: procedures>>=
module subroutine counter_allreduce_record (counter)
class(counter_t), intent(inout) :: counter
integer :: read, generated
integer :: positive, negative, zero, excess, dropped
real(default) :: max_excess, sum_excess
read = counter%read
generated = counter%generated
positive = counter%positive
negative = counter%negative
zero = counter%zero
excess = counter%excess
max_excess = counter%max_excess
sum_excess = counter%sum_excess
dropped = counter%dropped
call MPI_ALLREDUCE (read, counter%read, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
call MPI_ALLREDUCE (generated, counter%generated, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
call MPI_ALLREDUCE (positive, counter%positive, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
call MPI_ALLREDUCE (negative, counter%negative, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
call MPI_ALLREDUCE (zero, counter%zero, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
call MPI_ALLREDUCE (excess, counter%excess, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
call MPI_ALLREDUCE (max_excess, counter%max_excess, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD)
call MPI_ALLREDUCE (sum_excess, counter%sum_excess, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD)
call MPI_ALLREDUCE (dropped, counter%dropped, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
!! \todo{sbrass - Implement allreduce of mean and variance, relevant for weighted events.}
end subroutine counter_allreduce_record
@
<<Simulations: counter: TBP>>=
procedure :: record_mean_and_variance => &
counter_record_mean_and_variance
<<Simulations: sub interfaces>>=
module subroutine counter_record_mean_and_variance (counter, weight, i_nlo)
class(counter_t), intent(inout) :: counter
real(default), intent(in) :: weight
integer, intent(in) :: i_nlo
end subroutine counter_record_mean_and_variance
<<Simulations: procedures>>=
module subroutine counter_record_mean_and_variance (counter, weight, i_nlo)
class(counter_t), intent(inout) :: counter
real(default), intent(in) :: weight
integer, intent(in) :: i_nlo
real(default), save :: weight_buffer = 0._default
integer, save :: nlo_count = 1
if (.not. counter%reproduce_xsection) return
if (i_nlo == 1) then
call flush_weight_buffer (weight_buffer, nlo_count)
weight_buffer = weight
nlo_count = 1
else
weight_buffer = weight_buffer + weight
nlo_count = nlo_count + 1
end if
contains
subroutine flush_weight_buffer (w, n_nlo)
real(default), intent(in) :: w
integer, intent(in) :: n_nlo
integer :: n
real(default) :: mean_new
counter%nlo_weight_counter = counter%nlo_weight_counter + 1
!!! Minus 1 to take into account offset from initialization
n = counter%nlo_weight_counter - 1
if (n > 0) then
mean_new = counter%mean + (w / n_nlo - counter%mean) / n
if (n > 1) &
counter%varsq = counter%varsq - counter%varsq / (n - 1) + &
n * (mean_new - counter%mean)**2
counter%mean = mean_new
end if
end subroutine flush_weight_buffer
end subroutine counter_record_mean_and_variance
@ %def counter_record_mean_and_variance
@
\subsection{Simulation: component sets}
For each set of process components that share a MCI entry in the
process configuration, we keep a separate event record.
<<Simulations: types>>=
type :: mci_set_t
private
integer :: n_components = 0
integer, dimension(:), allocatable :: i_component
type(string_t), dimension(:), allocatable :: component_id
logical :: has_integral = .false.
real(default) :: integral = 0
real(default) :: error = 0
real(default) :: weight_mci = 0
type(counter_t) :: counter
contains
<<Simulations: mci set: TBP>>
end type mci_set_t
@ %def mci_set_t
@ Output.
<<Simulations: mci set: TBP>>=
procedure :: write => mci_set_write
<<Simulations: sub interfaces>>=
module subroutine mci_set_write (object, unit, pacified)
class(mci_set_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacified
end subroutine mci_set_write
<<Simulations: procedures>>=
module subroutine mci_set_write (object, unit, pacified)
class(mci_set_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacified
logical :: pacify
integer :: u, i
u = given_output_unit (unit)
pacify = .false.; if (present (pacified)) pacify = pacified
write (u, "(3x,A)") "Components:"
do i = 1, object%n_components
write (u, "(5x,I0,A,A,A)") object%i_component(i), &
": '", char (object%component_id(i)), "'"
end do
if (object%has_integral) then
if (pacify) then
write (u, "(3x,A," // FMT_15 // ")") "Integral = ", object%integral
write (u, "(3x,A," // FMT_15 // ")") "Error = ", object%error
write (u, "(3x,A,F9.6)") "Weight =", object%weight_mci
else
write (u, "(3x,A," // FMT_19 // ")") "Integral = ", object%integral
write (u, "(3x,A," // FMT_19 // ")") "Error = ", object%error
write (u, "(3x,A,F13.10)") "Weight =", object%weight_mci
end if
else
write (u, "(3x,A)") "Integral = [undefined]"
end if
call object%counter%write (u)
end subroutine mci_set_write
@ %def mci_set_write
@ Initialize: Get the indices and names for the process components
that will contribute to this set.
<<Simulations: mci set: TBP>>=
procedure :: init => mci_set_init
<<Simulations: sub interfaces>>=
module subroutine mci_set_init (object, i_mci, process)
class(mci_set_t), intent(out) :: object
integer, intent(in) :: i_mci
type(process_t), intent(in), target :: process
end subroutine mci_set_init
<<Simulations: procedures>>=
module subroutine mci_set_init (object, i_mci, process)
class(mci_set_t), intent(out) :: object
integer, intent(in) :: i_mci
type(process_t), intent(in), target :: process
integer :: i
call process%get_i_component (i_mci, object%i_component)
object%n_components = size (object%i_component)
allocate (object%component_id (object%n_components))
do i = 1, size (object%component_id)
object%component_id(i) = &
process%get_component_id (object%i_component(i))
end do
if (process%has_integral (i_mci)) then
object%integral = process%get_integral (i_mci)
object%error = process%get_error (i_mci)
object%has_integral = .true.
end if
end subroutine mci_set_init
@ %def mci_set_init
@
\subsection{Process-core Safe}
This is an object that temporarily holds a process core object. We
need this while rescanning a process with modified parameters. After
the rescan, we want to restore the original state.
<<Simulations: types>>=
type :: core_safe_t
class(prc_core_t), allocatable :: core
end type core_safe_t
@ %def core_safe_t
@
\subsection{Process Object}
The simulation works on process objects. This subroutine makes a
process object available for simulation. The process is in the
process stack. [[use_process]] implies that the process should
already exist as an object in the process stack. If integration is
not yet done, do it. Any generated process object should be put on
the global stack, if it is separate from the local one.
<<Simulations: procedures>>=
subroutine prepare_process &
(process, process_id, use_process, integrate, local, global)
type(process_t), pointer, intent(out) :: process
type(string_t), intent(in) :: process_id
logical, intent(in) :: use_process, integrate
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
type(rt_data_t), pointer :: current
if (debug_on) call msg_debug (D_CORE, "prepare_process")
if (debug_on) call msg_debug (D_CORE, "global present", present (global))
if (present (global)) then
current => global
else
current => local
end if
process => current%process_stack%get_process_ptr (process_id)
if (debug_on) call msg_debug (D_CORE, "use_process", use_process)
if (debug_on) call msg_debug (D_CORE, "associated process", associated (process))
if (use_process .and. .not. associated (process)) then
if (integrate) then
call msg_message ("Simulate: process '" &
// char (process_id) // "' needs integration")
else
call msg_message ("Simulate: process '" &
// char (process_id) // "' needs initialization")
end if
if (present (global)) then
call integrate_process (process_id, local, global, &
init_only = .not. integrate)
else
call integrate_process (process_id, local, &
local_stack = .true., init_only = .not. integrate)
end if
if (signal_is_pending ()) return
process => current%process_stack%get_process_ptr (process_id)
if (associated (process)) then
if (integrate) then
call msg_message ("Simulate: integration done")
call current%process_stack%fill_result_vars (process_id)
else
call msg_message ("Simulate: process initialization done")
end if
else
call msg_fatal ("Simulate: process '" &
// char (process_id) // "' could not be initialized: aborting")
end if
else if (.not. associated (process)) then
if (present (global)) then
call integrate_process (process_id, local, global, &
init_only = .true.)
else
call integrate_process (process_id, local, &
local_stack = .true., init_only = .true.)
end if
process => current%process_stack%get_process_ptr (process_id)
call msg_message &
("Simulate: process '" &
// char (process_id) // "': enabled for rescan only")
end if
end subroutine prepare_process
@ %def prepare_process
@
\subsection{Simulation-entry object}
For each process that we consider for event generation, we need a
separate entry. The entry separately records the process ID and run ID. The
[[weight_mci]] array is used for selecting a component set (which
shares an MCI record inside the process container) when generating an
event for the current process.
The simulation entry is an extension of the [[event_t]] event record.
This core object contains configuration data, pointers to the process
and process instance, the expressions, flags and values that are
evaluated at runtime, and the resulting particle set.
The entry explicitly allocates the [[process_instance]], which becomes
the process-specific workspace for the event record.
If entries with differing environments are present simultaneously, we
may need to switch QCD parameters and/or the model event by event. In
this case, the [[qcd]] and/or [[model]] components are present.
For the purpose of NLO events, [[entry_t]] contains a pointer list
to other simulation-entries. This is due to the fact that we have to
associate an event for each component of the fixed order simulation,
i.e. one $N$-particle event and $N_\text{phs}$ $N+1$-particle events.
However, all entries share the same event transforms.
<<Simulations: types>>=
type, extends (event_t) :: entry_t
private
type(string_t) :: process_id
type(string_t) :: library
type(string_t) :: run_id
logical :: has_integral = .false.
real(default) :: integral = 0
real(default) :: error = 0
real(default) :: process_weight = 0
logical :: valid = .false.
type(counter_t) :: counter
integer :: n_in = 0
integer :: n_mci = 0
type(mci_set_t), dimension(:), allocatable :: mci_sets
type(selector_t) :: mci_selector
logical :: has_resonant_subprocess_set = .false.
type(resonant_subprocess_set_t) :: resonant_subprocess_set
type(core_safe_t), dimension(:), allocatable :: core_safe
class(model_data_t), pointer :: model => null ()
type(qcd_t) :: qcd
type(entry_t), pointer :: first => null ()
type(entry_t), pointer :: next => null ()
class(evt_t), pointer :: evt_powheg => null ()
contains
<<Simulations: entry: TBP>>
end type entry_t
@ %def entry_t
@ Output. Write just the configuration, the event is written by a
separate routine.
The [[verbose]] option is unused, it is required by the interface of
the base-object method.
<<Simulations: entry: TBP>>=
procedure :: write_config => entry_write_config
<<Simulations: sub interfaces>>=
module subroutine entry_write_config (object, unit, pacified)
class(entry_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacified
end subroutine entry_write_config
<<Simulations: procedures>>=
module subroutine entry_write_config (object, unit, pacified)
class(entry_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacified
logical :: pacify
integer :: u, i
u = given_output_unit (unit)
pacify = .false.; if (present (pacified)) pacify = pacified
write (u, "(3x,A,A,A)") "Process = '", char (object%process_id), "'"
write (u, "(3x,A,A,A)") "Library = '", char (object%library), "'"
write (u, "(3x,A,A,A)") "Run = '", char (object%run_id), "'"
write (u, "(3x,A,L1)") "is valid = ", object%valid
if (object%has_integral) then
if (pacify) then
write (u, "(3x,A," // FMT_15 // ")") "Integral = ", object%integral
write (u, "(3x,A," // FMT_15 // ")") "Error = ", object%error
write (u, "(3x,A,F9.6)") "Weight =", object%process_weight
else
write (u, "(3x,A," // FMT_19 // ")") "Integral = ", object%integral
write (u, "(3x,A," // FMT_19 // ")") "Error = ", object%error
write (u, "(3x,A,F13.10)") "Weight =", object%process_weight
end if
else
write (u, "(3x,A)") "Integral = [undefined]"
end if
write (u, "(3x,A,I0)") "MCI sets = ", object%n_mci
call object%counter%write (u)
do i = 1, size (object%mci_sets)
write (u, "(A)")
write (u, "(1x,A,I0,A)") "MCI set #", i, ":"
call object%mci_sets(i)%write (u, pacified)
end do
if (object%resonant_subprocess_set%is_active ()) then
write (u, "(A)")
call object%write_resonant_subprocess_data (u)
end if
if (allocated (object%core_safe)) then
do i = 1, size (object%core_safe)
write (u, "(1x,A,I0,A)") "Saved process-component core #", i, ":"
call object%core_safe(i)%core%write (u)
end do
end if
end subroutine entry_write_config
@ %def entry_write_config
@ Finalizer. The [[instance]] pointer component of the [[event_t]]
base type points to a target which we did explicitly allocate in the
[[entry_init]] procedure. Therefore, we finalize and explicitly
deallocate it here. Then we call the finalizer of the base type.
<<Simulations: entry: TBP>>=
procedure :: final => entry_final
<<Simulations: sub interfaces>>=
module subroutine entry_final (object)
class(entry_t), intent(inout) :: object
end subroutine entry_final
<<Simulations: procedures>>=
module subroutine entry_final (object)
class(entry_t), intent(inout) :: object
integer :: i
if (associated (object%instance)) then
do i = 1, object%n_mci
call object%instance%final_simulation (i)
end do
call object%instance%final ()
deallocate (object%instance)
end if
call object%event_t%final ()
end subroutine entry_final
@ %def entry_final
@ Copy the content of an entry into another one, except for the next-pointer
<<Simulations: entry: TBP>>=
procedure :: copy_entry => entry_copy_entry
<<Simulations: sub interfaces>>=
module subroutine entry_copy_entry (entry1, entry2)
class(entry_t), intent(in), target :: entry1
type(entry_t), intent(inout), target :: entry2
end subroutine entry_copy_entry
<<Simulations: procedures>>=
module subroutine entry_copy_entry (entry1, entry2)
class(entry_t), intent(in), target :: entry1
type(entry_t), intent(inout), target :: entry2
call entry1%event_t%clone (entry2%event_t)
entry2%process_id = entry1%process_id
entry2%library = entry1%library
entry2%run_id = entry1%run_id
entry2%has_integral = entry1%has_integral
entry2%integral = entry1%integral
entry2%error = entry1%error
entry2%process_weight = entry1%process_weight
entry2%valid = entry1%valid
entry2%counter = entry1%counter
entry2%n_in = entry1%n_in
entry2%n_mci = entry1%n_mci
if (allocated (entry1%mci_sets)) then
allocate (entry2%mci_sets (size (entry1%mci_sets)))
entry2%mci_sets = entry1%mci_sets
end if
entry2%mci_selector = entry1%mci_selector
if (allocated (entry1%core_safe)) then
allocate (entry2%core_safe (size (entry1%core_safe)))
entry2%core_safe = entry1%core_safe
end if
entry2%model => entry1%model
entry2%qcd = entry1%qcd
end subroutine entry_copy_entry
@ %def entry_copy_entry
@
\subsubsection{Simulation-entry initialization}
Search for a process entry and allocate a process
instance as an anonymous object, temporarily accessible via the
[[process_instance]] pointer. Assign data by looking at the process
object and at the environment.
If [[n_alt]] is set, we prepare for additional alternate sqme and weight
entries.
The [[compile]] flag is only false if we do not need the Whizard
process at all, just its definition. In that case, we skip process
initialization.
Otherwise, and if the process object is not found initially: if
[[integrate]] is set, attempt an integration pass and try again.
Otherwise, just initialize the object.
If [[generate]] is set, prepare the MCI objects for generating new events.
For pure rescanning, this is not necessary.
If [[resonance_history]] is set, we create a separate process library
which contains all possible restricted subprocesses with distinct
resonance histories. These processes will not be integrated, but
their matrix element codes are used for determining probabilities of
resonance histories. Note that this can work only if the process
method is OMega, and the phase-space method is 'wood'.
When done, we assign the [[instance]] and [[process]] pointers of the
base type by the [[connect]] method, so we can reference them later.
TODO: In case of NLO event generation, copying the configuration from the
master process is rather intransparent. For instance, we override the process
var list by the global var list.
<<Simulations: entry: TBP>>=
procedure :: init => entry_init
<<Simulations: sub interfaces>>=
module subroutine entry_init &
(entry, process_id, &
use_process, integrate, generate, update_sqme, &
support_resonance_history, &
local, global, n_alt)
class(entry_t), intent(inout), target :: entry
type(string_t), intent(in) :: process_id
logical, intent(in) :: use_process, integrate, generate, update_sqme
logical, intent(in) :: support_resonance_history
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
integer, intent(in), optional :: n_alt
end subroutine entry_init
<<Simulations: procedures>>=
module subroutine entry_init &
(entry, process_id, &
use_process, integrate, generate, update_sqme, &
support_resonance_history, &
local, global, n_alt)
class(entry_t), intent(inout), target :: entry
type(string_t), intent(in) :: process_id
logical, intent(in) :: use_process, integrate, generate, update_sqme
logical, intent(in) :: support_resonance_history
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
integer, intent(in), optional :: n_alt
type(process_t), pointer :: process, master_process
type(process_instance_t), pointer :: process_instance
type(process_library_t), pointer :: prclib_saved
integer :: i
logical :: res_include_trivial
logical :: combined_integration
integer :: selected_mci
selected_mci = 0
if (debug_on) call msg_debug (D_CORE, "entry_init")
if (debug_on) call msg_debug (D_CORE, "process_id", process_id)
call prepare_process &
(master_process, process_id, use_process, integrate, local, global)
if (signal_is_pending ()) return
if (associated (master_process)) then
if (.not. master_process%has_matrix_element ()) then
entry%has_integral = .true.
entry%process_id = process_id
entry%valid = .false.
return
end if
else
call entry%basic_init (local%var_list)
entry%has_integral = .false.
entry%process_id = process_id
call entry%import_process_def_characteristics (local%prclib, process_id)
entry%valid = .true.
return
end if
call entry%basic_init (local%var_list, n_alt)
entry%process_id = process_id
if (generate .or. integrate) then
entry%run_id = master_process%get_run_id ()
process => master_process
else
call local%set_log (var_str ("?rebuild_phase_space"), &
.false., is_known = .true.)
call local%set_log (var_str ("?check_phs_file"), &
.false., is_known = .true.)
call local%set_log (var_str ("?rebuild_grids"), &
.false., is_known = .true.)
entry%run_id = &
local%var_list%get_sval (var_str ("$run_id"))
if (update_sqme) then
call prepare_local_process (process, process_id, local)
else
process => master_process
end if
end if
call entry%import_process_characteristics (process)
allocate (entry%mci_sets (entry%n_mci))
do i = 1, size (entry%mci_sets)
call entry%mci_sets(i)%init (i, master_process)
end do
call entry%import_process_results (master_process)
call entry%prepare_expressions (local)
if (process%is_nlo_calculation ()) then
call process%init_nlo_settings (global%var_list)
end if
combined_integration = local%get_lval (var_str ("?combined_nlo_integration"))
if (.not. combined_integration) &
selected_mci = process%extract_active_component_mci ()
call prepare_process_instance (process_instance, process, local%model, &
local = local)
if (generate) then
if (selected_mci > 0) then
call process%prepare_simulation (selected_mci)
call process_instance%init_simulation (selected_mci, entry%config%safety_factor, &
local%get_lval (var_str ("?keep_failed_events")))
else
do i = 1, entry%n_mci
call process%prepare_simulation (i)
call process_instance%init_simulation (i, entry%config%safety_factor, &
local%get_lval (var_str ("?keep_failed_events")))
end do
end if
end if
if (support_resonance_history) then
prclib_saved => local%prclib
call entry%setup_resonant_subprocesses (local, process)
if (entry%has_resonant_subprocess_set) then
if (signal_is_pending ()) return
call entry%compile_resonant_subprocesses (local)
if (signal_is_pending ()) return
call entry%prepare_resonant_subprocesses (local, global)
if (signal_is_pending ()) return
call entry%prepare_resonant_subprocess_instances (local)
end if
if (signal_is_pending ()) return
if (associated (prclib_saved)) call local%update_prclib (prclib_saved)
end if
call entry%setup_event_transforms (process, local)
call dispatch_qcd (entry%qcd, local%get_var_list_ptr (), local%os_data)
call entry%connect_qcd ()
if (present (global)) then
call entry%connect (process_instance, local%model, global%process_stack)
else
call entry%connect (process_instance, local%model, local%process_stack)
end if
call entry%setup_expressions ()
entry%model => process%get_model_ptr ()
entry%valid = .true.
end subroutine entry_init
@ %def entry_init
@
<<Simulations: entry: TBP>>=
procedure :: set_active_real_components => entry_set_active_real_components
<<Simulations: sub interfaces>>=
module subroutine entry_set_active_real_components (entry)
class(entry_t), intent(inout) :: entry
end subroutine entry_set_active_real_components
<<Simulations: procedures>>=
module subroutine entry_set_active_real_components (entry)
class(entry_t), intent(inout) :: entry
integer :: i_active_real
select type (pcm => entry%instance%pcm)
class is (pcm_nlo_t)
i_active_real = entry%instance%get_real_of_mci ()
if (debug_on) call msg_debug2 (D_CORE, "i_active_real", i_active_real)
if (associated (entry%evt_powheg)) then
select type (evt => entry%evt_powheg)
type is (evt_shower_t)
if (entry%process%get_component_type(i_active_real) == &
COMP_REAL_FIN) then
if (debug_on) call msg_debug &
(D_CORE, "Disabling Powheg matching for ", i_active_real)
call evt%disable_powheg_matching ()
else
if (debug_on) call msg_debug &
(D_CORE, "Enabling Powheg matching for ", i_active_real)
call evt%enable_powheg_matching ()
end if
class default
call msg_fatal ("powheg-evt should be evt_shower_t!")
end select
end if
end select
end subroutine entry_set_active_real_components
@ %def entry_set_active_real_components
@ Part of simulation-entry initialization: set up a process object for
local use.
<<Simulations: procedures>>=
subroutine prepare_local_process (process, process_id, local)
type(process_t), pointer, intent(inout) :: process
type(string_t), intent(in) :: process_id
type(rt_data_t), intent(inout), target :: local
type(integration_t) :: intg
call intg%create_process (process_id)
call intg%init_process (local)
call intg%setup_process (local, verbose=.false.)
process => intg%get_process_ptr ()
end subroutine prepare_local_process
@ %def prepare_local_process
@ Part of simulation-entry initialization: set up a process instance
matching the selected process object.
The model that we can provide as an extra argument can modify particle
settings (polarization) in the density matrices that will be constructed. It
does not affect parameters.
<<Restricted subprocesses: sub interfaces>>=
<<Simulations: procedures>>=
subroutine prepare_process_instance &
(process_instance, process, model, local)
type(process_instance_t), pointer, intent(inout) :: process_instance
type(process_t), intent(inout), target :: process
class(model_data_t), intent(in), optional :: model
type(rt_data_t), intent(in), optional, target :: local
allocate (process_instance)
call process_instance%init (process)
if (process%is_nlo_calculation ()) then
select type (pcm_work => process_instance%pcm_work)
type is (pcm_nlo_workspace_t)
select type (pcm => process_instance%pcm)
type is (pcm_nlo_t)
if (.not. pcm%settings%combined_integration) &
call pcm_work%set_radiation_event ()
if (pcm%settings%fixed_order_nlo) &
call pcm_work%set_fixed_order_event_mode ()
end select
end select
call process%prepare_any_external_code ()
end if
call process_instance%setup_event_data (model)
end subroutine prepare_process_instance
@ %def prepare_process_instance
@ Part of simulation-entry initialization: query the
process for basic information.
<<Simulations: entry: TBP>>=
procedure, private :: import_process_characteristics &
=> entry_import_process_characteristics
<<Simulations: sub interfaces>>=
module subroutine entry_import_process_characteristics (entry, process)
class(entry_t), intent(inout) :: entry
type(process_t), intent(in), target :: process
end subroutine entry_import_process_characteristics
<<Simulations: procedures>>=
module subroutine entry_import_process_characteristics (entry, process)
class(entry_t), intent(inout) :: entry
type(process_t), intent(in), target :: process
entry%library = process%get_library_name ()
entry%n_in = process%get_n_in ()
entry%n_mci = process%get_n_mci ()
end subroutine entry_import_process_characteristics
@ %def entry_import_process_characteristics
@ This is the alternative form which applies if there is no process
entry, but just a process definition which we take from the provided
[[prclib]] definition library.
<<Simulations: entry: TBP>>=
procedure, private :: import_process_def_characteristics &
=> entry_import_process_def_characteristics
<<Simulations: sub interfaces>>=
module subroutine entry_import_process_def_characteristics &
(entry, prclib, id)
class(entry_t), intent(inout) :: entry
type(process_library_t), intent(in), target :: prclib
type(string_t), intent(in) :: id
end subroutine entry_import_process_def_characteristics
<<Simulations: procedures>>=
module subroutine entry_import_process_def_characteristics (entry, prclib, id)
class(entry_t), intent(inout) :: entry
type(process_library_t), intent(in), target :: prclib
type(string_t), intent(in) :: id
entry%library = prclib%get_name ()
entry%n_in = prclib%get_n_in (id)
end subroutine entry_import_process_def_characteristics
@ %def entry_import_process_def_characteristics
@ Part of simulation-entry initialization: query the
process for integration results.
<<Simulations: entry: TBP>>=
procedure, private :: import_process_results &
=> entry_import_process_results
<<Simulations: sub interfaces>>=
module subroutine entry_import_process_results (entry, process)
class(entry_t), intent(inout) :: entry
type(process_t), intent(in), target :: process
end subroutine entry_import_process_results
<<Simulations: procedures>>=
module subroutine entry_import_process_results (entry, process)
class(entry_t), intent(inout) :: entry
type(process_t), intent(in), target :: process
if (process%has_integral ()) then
entry%integral = process%get_integral ()
entry%error = process%get_error ()
call entry%set_sigma (entry%integral)
entry%has_integral = .true.
end if
end subroutine entry_import_process_results
@ %def entry_import_process_results
@ Part of simulation-entry initialization: create expression factory
objects and store them.
<<Simulations: entry: TBP>>=
procedure, private :: prepare_expressions &
=> entry_prepare_expressions
<<Simulations: sub interfaces>>=
module subroutine entry_prepare_expressions (entry, local)
class(entry_t), intent(inout) :: entry
type(rt_data_t), intent(in), target :: local
end subroutine entry_prepare_expressions
<<Simulations: procedures>>=
module subroutine entry_prepare_expressions (entry, local)
class(entry_t), intent(inout) :: entry
type(rt_data_t), intent(in), target :: local
type(eval_tree_factory_t) :: expr_factory
call expr_factory%init (local%pn%selection_lexpr)
call entry%set_selection (expr_factory)
call expr_factory%init (local%pn%reweight_expr)
call entry%set_reweight (expr_factory)
call expr_factory%init (local%pn%analysis_lexpr)
call entry%set_analysis (expr_factory)
end subroutine entry_prepare_expressions
@ %def entry_prepare_expressions
@
\subsubsection{Extra (NLO) entries}
Initializes the list of additional NLO entries. The routine gets the
information about how many entries to associate from [[region_data]].
<<Simulations: entry: TBP>>=
procedure :: setup_additional_entries => entry_setup_additional_entries
<<Simulations: sub interfaces>>=
module subroutine entry_setup_additional_entries (entry)
class(entry_t), intent(inout), target :: entry
end subroutine entry_setup_additional_entries
<<Simulations: procedures>>=
module subroutine entry_setup_additional_entries (entry)
class(entry_t), intent(inout), target :: entry
type(entry_t), pointer :: current_entry
integer :: i, n_phs
type(evt_nlo_t), pointer :: evt
integer :: mode
evt => null ()
select type (pcm => entry%instance%pcm)
type is (pcm_nlo_t)
n_phs = pcm%region_data%n_phs
end select
select type (entry)
type is (entry_t)
current_entry => entry
current_entry%first => entry
call get_nlo_evt_ptr (current_entry, evt, mode)
if (mode > EVT_NLO_SEPARATE_BORNLIKE) then
allocate (evt%particle_set_nlo (n_phs + 1))
evt%event_deps%n_phs = n_phs
evt%qcd = entry%qcd
do i = 1, n_phs
allocate (current_entry%next)
current_entry%next%first => current_entry%first
current_entry => current_entry%next
call entry%copy_entry (current_entry)
current_entry%i_event = i
end do
else
allocate (evt%particle_set_nlo (1))
end if
end select
contains
subroutine get_nlo_evt_ptr (entry, evt, mode)
type(entry_t), intent(in), target :: entry
type(evt_nlo_t), intent(out), pointer :: evt
integer, intent(out) :: mode
class(evt_t), pointer :: current_evt
evt => null ()
current_evt => entry%transform_first
do
select type (current_evt)
type is (evt_nlo_t)
evt => current_evt
mode = evt%mode
exit
end select
if (associated (current_evt%next)) then
current_evt => current_evt%next
else
call msg_fatal ("evt_nlo not in list of event transforms")
end if
end do
end subroutine get_nlo_evt_ptr
end subroutine entry_setup_additional_entries
@ %def entry_setup_additional_entries
@
<<Simulations: entry: TBP>>=
procedure :: get_first => entry_get_first
<<Simulations: sub interfaces>>=
module function entry_get_first (entry) result (entry_out)
class(entry_t), intent(in), target :: entry
type(entry_t), pointer :: entry_out
end function entry_get_first
<<Simulations: procedures>>=
module function entry_get_first (entry) result (entry_out)
class(entry_t), intent(in), target :: entry
type(entry_t), pointer :: entry_out
entry_out => null ()
select type (entry)
type is (entry_t)
if (entry%is_nlo ()) then
entry_out => entry%first
else
entry_out => entry
end if
end select
end function entry_get_first
@ %def entry_get_first
@
<<Simulations: entry: TBP>>=
procedure :: get_next => entry_get_next
<<Simulations: sub interfaces>>=
module function entry_get_next (entry) result (next_entry)
class(entry_t), intent(in) :: entry
type(entry_t), pointer :: next_entry
end function entry_get_next
<<Simulations: procedures>>=
module function entry_get_next (entry) result (next_entry)
class(entry_t), intent(in) :: entry
type(entry_t), pointer :: next_entry
next_entry => null ()
if (associated (entry%next)) then
next_entry => entry%next
else
call msg_fatal ("Get next entry: No next entry")
end if
end function entry_get_next
@ %def entry_get_next
@
<<Simulations: entry: TBP>>=
procedure :: count_nlo_entries => entry_count_nlo_entries
<<Simulations: sub interfaces>>=
module function entry_count_nlo_entries (entry) result (n)
class(entry_t), intent(in), target :: entry
integer :: n
end function entry_count_nlo_entries
<<Simulations: procedures>>=
module function entry_count_nlo_entries (entry) result (n)
class(entry_t), intent(in), target :: entry
integer :: n
type(entry_t), pointer :: current_entry
n = 1
if (.not. associated (entry%next)) then
return
else
current_entry => entry%next
do
n = n + 1
if (.not. associated (current_entry%next)) exit
current_entry => current_entry%next
end do
end if
end function entry_count_nlo_entries
@ %def entry_count_nlo_entries
@
<<Simulations: entry: TBP>>=
procedure :: reset_nlo_counter => entry_reset_nlo_counter
<<Simulations: sub interfaces>>=
module subroutine entry_reset_nlo_counter (entry)
class(entry_t), intent(inout) :: entry
end subroutine entry_reset_nlo_counter
<<Simulations: procedures>>=
module subroutine entry_reset_nlo_counter (entry)
class(entry_t), intent(inout) :: entry
class(evt_t), pointer :: evt
evt => entry%transform_first
do
select type (evt)
type is (evt_nlo_t)
evt%i_evaluation = 0
exit
end select
if (associated (evt%next)) evt => evt%next
end do
end subroutine entry_reset_nlo_counter
@ %def entry_reset_nlo_counter
@
<<Simulations: entry: TBP>>=
procedure :: determine_if_powheg_matching => &
entry_determine_if_powheg_matching
<<Simulations: sub interfaces>>=
module subroutine entry_determine_if_powheg_matching (entry)
class(entry_t), intent(inout) :: entry
end subroutine entry_determine_if_powheg_matching
<<Simulations: procedures>>=
module subroutine entry_determine_if_powheg_matching (entry)
class(entry_t), intent(inout) :: entry
class(evt_t), pointer :: current_transform
if (associated (entry%transform_first)) then
current_transform => entry%transform_first
do
select type (current_transform)
type is (evt_shower_t)
if (current_transform%contains_powheg_matching ()) &
entry%evt_powheg => current_transform
exit
end select
if (associated (current_transform%next)) then
current_transform => current_transform%next
else
exit
end if
end do
end if
end subroutine entry_determine_if_powheg_matching
@ %def entry_determine_if_powheg_matching
@
\subsubsection{Event-transform initialization}
Part of simulation-entry initialization: dispatch event transforms
(decay, shower) as requested. If a transform is not applicable or
switched off via some variable, it will be skipped.
Regarding resonances/decays: these two transforms are currently mutually
exclusive. Resonance insertion will not be applied if there is an
unstable particle in the game.
The initial particle set is the output of the trivial transform; this
has already been applied when the transforms listed here are
encountered. Each transform takes a particle set and produces a new
one, with one exception: the decay module takes its input from the
process object, ignoring the trivial transform. (Reason: spin
correlations.) Therefore, the decay module must be first in line.
Settings that we don't or can't support (yet) are rejected by the
embedded call to [[event_transforms_check]].
<<Simulations: entry: TBP>>=
procedure, private :: setup_event_transforms &
=> entry_setup_event_transforms
<<Simulations: sub interfaces>>=
module subroutine entry_setup_event_transforms (entry, process, local)
class(entry_t), intent(inout) :: entry
type(process_t), intent(inout), target :: process
type(rt_data_t), intent(in), target :: local
end subroutine entry_setup_event_transforms
<<Simulations: procedures>>=
module subroutine entry_setup_event_transforms (entry, process, local)
class(entry_t), intent(inout) :: entry
type(process_t), intent(inout), target :: process
type(rt_data_t), intent(in), target :: local
class(evt_t), pointer :: evt
type(var_list_t), pointer :: var_list
logical :: enable_isr_handler
logical :: enable_epa_handler
logical :: enable_fixed_order
logical :: enable_shower
character(len=7) :: sample_normalization
call event_transforms_check (entry, process, local)
var_list => local%get_var_list_ptr ()
if (process%contains_unstable (local%model)) then
call dispatch_evt_decay (evt, local%var_list)
if (associated (evt)) call entry%import_transform (evt)
end if
if (entry%resonant_subprocess_set%is_active ()) then
call dispatch_evt_resonance (evt, local%var_list, &
entry%resonant_subprocess_set%get_resonance_history_set (), &
entry%resonant_subprocess_set%get_libname ())
if (associated (evt)) then
call entry%resonant_subprocess_set%connect_transform (evt)
call entry%resonant_subprocess_set%set_on_shell_limit &
(local%get_rval (var_str ("resonance_on_shell_limit")))
call entry%resonant_subprocess_set%set_on_shell_turnoff &
(local%get_rval (var_str ("resonance_on_shell_turnoff")))
call entry%resonant_subprocess_set%set_background_factor &
(local%get_rval (var_str ("resonance_background_factor")))
call entry%import_transform (evt)
end if
end if
enable_fixed_order = local%get_lval (var_str ("?fixed_order_nlo_events"))
if (enable_fixed_order) then
call dispatch_evt_nlo &
(evt, local%get_lval (var_str ("?keep_failed_events")))
call entry%import_transform (evt)
end if
enable_isr_handler = local%get_lval (var_str ("?isr_handler"))
enable_epa_handler = local%get_lval (var_str ("?epa_handler"))
if (enable_isr_handler .or. enable_epa_handler) then
call dispatch_evt_isr_epa_handler (evt, local%var_list)
if (associated (evt)) call entry%import_transform (evt)
end if
enable_shower = local%get_lval (var_str ("?allow_shower")) .and. &
(local%get_lval (var_str ("?ps_isr_active")) &
.or. local%get_lval (var_str ("?ps_fsr_active")) &
.or. local%get_lval (var_str ("?muli_active")) &
.or. local%get_lval (var_str ("?mlm_matching")) &
.or. local%get_lval (var_str ("?ckkw_matching")) &
.or. local%get_lval (var_str ("?powheg_matching")))
if (enable_shower) then
call dispatch_evt_shower (evt, var_list, local%model, &
local%fallback_model, local%os_data, local%beam_structure, &
process)
call entry%import_transform (evt)
end if
if (local%get_lval (var_str ("?hadronization_active"))) then
call dispatch_evt_hadrons (evt, var_list, local%fallback_model)
call entry%import_transform (evt)
end if
end subroutine entry_setup_event_transforms
@ %def entry_setup_event_transforms
@
This routine rejects all event-transform settings which we don't
support at present.
<<Simulations: procedures>>=
subroutine event_transforms_check (entry, process, local)
class(entry_t), intent(in) :: entry
type(process_t), intent(in), target :: process
type(rt_data_t), intent(in), target :: local
if (local%get_lval (var_str ("?fixed_order_nlo_events"))) then
if (local%get_lval (var_str ("?unweighted"))) then
call msg_fatal ("NLO fixed-order events have to be generated with &
&?unweighted = false")
end if
select case (char (local%get_sval (var_str ("$sample_normalization"))))
case ("sigma", "auto")
case default
call msg_fatal ("NLO fixed-order events: only &
&$sample_normalization = 'sigma' is supported.")
end select
if (process%contains_unstable (local%model)) then
call msg_fatal ("NLO fixed-order events: unstable final-state &
&particles not supported yet")
end if
if (entry%resonant_subprocess_set%is_active ()) then
call msg_fatal ("NLO fixed-order events: resonant subprocess &
&insertion not supported")
end if
if (local%get_lval (var_str ("?isr_handler")) &
.or. local%get_lval (var_str ("?epa_handler"))) then
call msg_fatal ("NLO fixed-order events: ISR handler for &
&photon-pT generation not supported yet")
end if
end if
if (process%contains_unstable (local%model) &
.and. entry%resonant_subprocess_set%is_active ()) then
call msg_fatal ("Simulation: resonant subprocess insertion with &
&unstable final-state particles not supported")
end if
end subroutine event_transforms_check
@ %def event_transforms_check
@
\subsubsection{Process/MCI selector}
Compute weights. The integral in the argument is the sum of integrals for
all processes in the sample. After computing the process weights, we repeat
the normalization procedure for the process components.
<<Simulations: entry: TBP>>=
procedure :: init_mci_selector => entry_init_mci_selector
<<Simulations: sub interfaces>>=
module subroutine entry_init_mci_selector (entry, negative_weights)
class(entry_t), intent(inout), target :: entry
logical, intent(in), optional :: negative_weights
end subroutine entry_init_mci_selector
<<Simulations: procedures>>=
module subroutine entry_init_mci_selector (entry, negative_weights)
class(entry_t), intent(inout), target :: entry
logical, intent(in), optional :: negative_weights
type(entry_t), pointer :: current_entry
integer :: i, j, k
if (debug_on) call msg_debug (D_CORE, "entry_init_mci_selector")
if (entry%has_integral) then
select type (entry)
type is (entry_t)
current_entry => entry
do j = 1, current_entry%count_nlo_entries ()
if (j > 1) current_entry => current_entry%get_next ()
do k = 1, size(current_entry%mci_sets%integral)
if (debug_on) call msg_debug &
(D_CORE, "current_entry%mci_sets(k)%integral", &
current_entry%mci_sets(k)%integral)
end do
call current_entry%mci_selector%init &
(current_entry%mci_sets%integral, negative_weights)
do i = 1, current_entry%n_mci
current_entry%mci_sets(i)%weight_mci = &
current_entry%mci_selector%get_weight (i)
end do
end do
end select
end if
end subroutine entry_init_mci_selector
@ %def entry_init_mci_selector
@ Select a MCI entry, using the embedded random-number generator.
<<Simulations: entry: TBP>>=
procedure :: select_mci => entry_select_mci
<<Simulations: sub interfaces>>=
module function entry_select_mci (entry) result (i_mci)
class(entry_t), intent(inout) :: entry
integer :: i_mci
end function entry_select_mci
<<Simulations: procedures>>=
module function entry_select_mci (entry) result (i_mci)
class(entry_t), intent(inout) :: entry
integer :: i_mci
if (debug_on) call msg_debug2 (D_CORE, "entry_select_mci")
i_mci = entry%process%extract_active_component_mci ()
if (i_mci == 0) call entry%mci_selector%generate (entry%rng, i_mci)
if (debug_on) call msg_debug2 (D_CORE, "i_mci", i_mci)
end function entry_select_mci
@ %def entry_select_mci
@
\subsubsection{Entries: event-wise updates}
Record an event for this entry, i.e., increment the appropriate counters.
<<Simulations: entry: TBP>>=
procedure :: record => entry_record
<<Simulations: sub interfaces>>=
module subroutine entry_record (entry, i_mci, from_file)
class(entry_t), intent(inout) :: entry
integer, intent(in) :: i_mci
logical, intent(in), optional :: from_file
end subroutine entry_record
<<Simulations: procedures>>=
module subroutine entry_record (entry, i_mci, from_file)
class(entry_t), intent(inout) :: entry
integer, intent(in) :: i_mci
logical, intent(in), optional :: from_file
real(default) :: weight, excess
integer :: n_dropped
weight = entry%get_weight_prc ()
excess = entry%get_excess_prc ()
n_dropped = entry%get_n_dropped ()
call entry%counter%record (weight, excess, n_dropped, from_file)
if (i_mci > 0) then
call entry%mci_sets(i_mci)%counter%record (weight, excess)
end if
end subroutine entry_record
@ %def entry_record
@ Update and restore the process core that this entry accesses, when
parameters change. If explicit arguments [[model]], [[qcd]], or
[[helicity_selection]] are provided, use those. Otherwise use the
parameters stored in the process object.
These two procedures come with a caching mechanism which guarantees
that the current core object is saved when calling [[update_process]],
and restored by calling [[restore_process]]. If the flag [[saved]] is
unset, saving is skipped, and the [[restore]] procedure should not be
called.
<<Simulations: entry: TBP>>=
procedure :: update_process => entry_update_process
procedure :: restore_process => entry_restore_process
<<Simulations: sub interfaces>>=
module subroutine entry_update_process &
(entry, model, qcd, helicity_selection, saved)
class(entry_t), intent(inout) :: entry
class(model_data_t), intent(in), optional, target :: model
type(qcd_t), intent(in), optional :: qcd
type(helicity_selection_t), intent(in), optional :: helicity_selection
logical, intent(in), optional :: saved
end subroutine entry_update_process
module subroutine entry_restore_process (entry)
class(entry_t), intent(inout) :: entry
end subroutine entry_restore_process
<<Simulations: procedures>>=
module subroutine entry_update_process &
(entry, model, qcd, helicity_selection, saved)
class(entry_t), intent(inout) :: entry
class(model_data_t), intent(in), optional, target :: model
type(qcd_t), intent(in), optional :: qcd
type(helicity_selection_t), intent(in), optional :: helicity_selection
logical, intent(in), optional :: saved
type(process_t), pointer :: process
class(prc_core_t), allocatable :: core
integer :: i, n_terms
class(model_data_t), pointer :: model_local
type(qcd_t) :: qcd_local
logical :: use_saved
if (present (model)) then
model_local => model
else
model_local => entry%model
end if
if (present (qcd)) then
qcd_local = qcd
else
qcd_local = entry%qcd
end if
use_saved = .true.; if (present (saved)) use_saved = saved
process => entry%get_process_ptr ()
n_terms = process%get_n_terms ()
if (use_saved) allocate (entry%core_safe (n_terms))
do i = 1, n_terms
if (process%has_matrix_element (i, is_term_index = .true.)) then
call process%extract_core (i, core)
if (use_saved) then
call dispatch_core_update (core, &
model_local, helicity_selection, qcd_local, &
entry%core_safe(i)%core)
else
call dispatch_core_update (core, &
model_local, helicity_selection, qcd_local)
end if
call process%restore_core (i, core)
end if
end do
end subroutine entry_update_process
module subroutine entry_restore_process (entry)
class(entry_t), intent(inout) :: entry
type(process_t), pointer :: process
class(prc_core_t), allocatable :: core
integer :: i, n_terms
process => entry%get_process_ptr ()
n_terms = process%get_n_terms ()
do i = 1, n_terms
if (process%has_matrix_element (i, is_term_index = .true.)) then
call process%extract_core (i, core)
call dispatch_core_restore (core, entry%core_safe(i)%core)
call process%restore_core (i, core)
end if
end do
deallocate (entry%core_safe)
end subroutine entry_restore_process
@ %def entry_update_process
@ %def entry_restore_process
<<Simulations: entry: TBP>>=
procedure :: connect_qcd => entry_connect_qcd
<<Simulations: sub interfaces>>=
module subroutine entry_connect_qcd (entry)
class(entry_t), intent(inout), target :: entry
end subroutine entry_connect_qcd
<<Simulations: procedures>>=
module subroutine entry_connect_qcd (entry)
class(entry_t), intent(inout), target :: entry
class(evt_t), pointer :: evt
evt => entry%transform_first
do while (associated (evt))
select type (evt)
type is (evt_shower_t)
evt%qcd = entry%qcd
if (allocated (evt%matching)) then
evt%matching%qcd = entry%qcd
end if
end select
evt => evt%next
end do
end subroutine entry_connect_qcd
@ %def entry_connect_qcd
@
\subsection{Handling resonant subprocesses}
Resonant subprocesses are required if we want to determine resonance histories
when generating events. The feature is optional, to be switched on by
the user.
This procedure initializes a new, separate process library that
contains copies of the current process, restricted to the relevant
resonance histories. (If this library exists already, it is just
kept.) The histories can be extracted from the process object.
The code has to match the assignments in
[[create_resonant_subprocess_library]]. The library may already
exist -- in that case, here it will be recovered without recompilation.
<<Simulations: entry: TBP>>=
procedure :: setup_resonant_subprocesses &
=> entry_setup_resonant_subprocesses
<<Simulations: sub interfaces>>=
module subroutine entry_setup_resonant_subprocesses (entry, global, process)
class(entry_t), intent(inout) :: entry
type(rt_data_t), intent(inout), target :: global
type(process_t), intent(in), target :: process
end subroutine entry_setup_resonant_subprocesses
<<Simulations: procedures>>=
module subroutine entry_setup_resonant_subprocesses (entry, global, process)
class(entry_t), intent(inout) :: entry
type(rt_data_t), intent(inout), target :: global
type(process_t), intent(in), target :: process
type(string_t) :: libname
type(resonance_history_set_t) :: res_history_set
type(process_library_t), pointer :: lib
type(process_component_def_t), pointer :: process_component_def
logical :: req_resonant, library_exist
integer :: i_component
libname = process%get_library_name ()
lib => global%prclib_stack%get_library_ptr (libname)
entry%has_resonant_subprocess_set = lib%req_resonant (process%get_id ())
if (entry%has_resonant_subprocess_set) then
libname = get_libname_res (process%get_id ())
call entry%resonant_subprocess_set%init (process%get_n_components ())
call entry%resonant_subprocess_set%create_library &
(libname, global, library_exist)
do i_component = 1, process%get_n_components ()
- call process%extract_resonance_history_set &
- (res_history_set, i_component = i_component)
- call entry%resonant_subprocess_set%fill_resonances &
- (res_history_set, i_component)
- if (.not. library_exist) then
- process_component_def &
- => process%get_component_def_ptr (i_component)
- call entry%resonant_subprocess_set%add_to_library &
- (i_component, &
- process_component_def%get_prt_spec_in (), &
- process_component_def%get_prt_spec_out (), &
- global)
- end if
+ select case (process%get_component_type (i_component))
+ case (COMP_MASTER, COMP_REAL_FIN, COMP_REAL_SING, COMP_REAL)
+ call process%extract_resonance_history_set &
+ (res_history_set, i_component = i_component)
+ call entry%resonant_subprocess_set%fill_resonances &
+ (res_history_set, i_component)
+ if (.not. library_exist) then
+ process_component_def &
+ => process%get_component_def_ptr (i_component)
+ call entry%resonant_subprocess_set%add_to_library &
+ (i_component, &
+ process_component_def%get_prt_spec_in (), &
+ process_component_def%get_prt_spec_out (), &
+ global)
+ end if
+ end select
end do
call entry%resonant_subprocess_set%freeze_library (global)
end if
end subroutine entry_setup_resonant_subprocesses
@ %def entry_setup_resonant_subprocesses
@ Compile the resonant-subprocesses library. The library is assumed
to be the current library in the [[global]] object. This is a simple wrapper.
<<Simulations: entry: TBP>>=
procedure :: compile_resonant_subprocesses &
=> entry_compile_resonant_subprocesses
<<Simulations: sub interfaces>>=
module subroutine entry_compile_resonant_subprocesses (entry, global)
class(entry_t), intent(inout) :: entry
type(rt_data_t), intent(inout), target :: global
end subroutine entry_compile_resonant_subprocesses
<<Simulations: procedures>>=
module subroutine entry_compile_resonant_subprocesses (entry, global)
class(entry_t), intent(inout) :: entry
type(rt_data_t), intent(inout), target :: global
call entry%resonant_subprocess_set%compile_library (global)
end subroutine entry_compile_resonant_subprocesses
@ %def entry_compile_resonant_subprocesses
@ Prepare process objects for the resonant-subprocesses library. The
process objects are appended to the global process stack. We
initialize the processes, such that we can evaluate matrix elements,
but we do not need to integrate them.
<<Simulations: entry: TBP>>=
procedure :: prepare_resonant_subprocesses &
=> entry_prepare_resonant_subprocesses
<<Simulations: sub interfaces>>=
module subroutine entry_prepare_resonant_subprocesses (entry, local, global)
class(entry_t), intent(inout) :: entry
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
end subroutine entry_prepare_resonant_subprocesses
<<Simulations: procedures>>=
module subroutine entry_prepare_resonant_subprocesses (entry, local, global)
class(entry_t), intent(inout) :: entry
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
call entry%resonant_subprocess_set%prepare_process_objects (local, global)
end subroutine entry_prepare_resonant_subprocesses
@ %def entry_prepare_resonant_subprocesses
@ Prepare process instances. They are linked to their corresponding process
objects. Both, process and instance objects, are allocated as anonymous
targets inside the [[resonant_subprocess_set]] component.
NOTE: those anonymous object are likely forgotten during finalization of the
parent [[event_t]] (extended as [[entry_t]]) object. This should be checked!
The memory leak is probably harmless as long as the event object is created
once per run, not once per event.
<<Simulations: entry: TBP>>=
procedure :: prepare_resonant_subprocess_instances &
=> entry_prepare_resonant_subprocess_instances
<<Simulations: sub interfaces>>=
module subroutine entry_prepare_resonant_subprocess_instances &
(entry, global)
class(entry_t), intent(inout) :: entry
type(rt_data_t), intent(in), target :: global
end subroutine entry_prepare_resonant_subprocess_instances
<<Simulations: procedures>>=
module subroutine entry_prepare_resonant_subprocess_instances (entry, global)
class(entry_t), intent(inout) :: entry
type(rt_data_t), intent(in), target :: global
call entry%resonant_subprocess_set%prepare_process_instances (global)
end subroutine entry_prepare_resonant_subprocess_instances
@ %def entry_prepare_resonant_subprocess_instances
@ Display the resonant subprocesses. This includes, upon request, the
resonance set that defines those subprocess, and a short or long account of the
process objects themselves.
<<Simulations: entry: TBP>>=
procedure :: write_resonant_subprocess_data &
=> entry_write_resonant_subprocess_data
<<Simulations: sub interfaces>>=
module subroutine entry_write_resonant_subprocess_data (entry, unit)
class(entry_t), intent(in) :: entry
integer, intent(in), optional :: unit
end subroutine entry_write_resonant_subprocess_data
<<Simulations: procedures>>=
module subroutine entry_write_resonant_subprocess_data (entry, unit)
class(entry_t), intent(in) :: entry
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
call entry%resonant_subprocess_set%write (unit)
write (u, "(1x,A,I0)") "Resonant subprocesses refer to &
&process component #", 1
end subroutine entry_write_resonant_subprocess_data
@ %def entry_write_resonant_subprocess_data
@ Display of the master process for the current event, for diagnostics.
<<Simulations: entry: TBP>>=
procedure :: write_process_data => entry_write_process_data
<<Simulations: sub interfaces>>=
module subroutine entry_write_process_data &
(entry, unit, show_process, show_instance, verbose)
class(entry_t), intent(in) :: entry
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_process
logical, intent(in), optional :: show_instance
logical, intent(in), optional :: verbose
end subroutine entry_write_process_data
<<Simulations: procedures>>=
module subroutine entry_write_process_data &
(entry, unit, show_process, show_instance, verbose)
class(entry_t), intent(in) :: entry
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_process
logical, intent(in), optional :: show_instance
logical, intent(in), optional :: verbose
integer :: u, i
logical :: s_proc, s_inst, verb
type(process_t), pointer :: process
type(process_instance_t), pointer :: instance
u = given_output_unit (unit)
s_proc = .false.; if (present (show_process)) s_proc = show_process
s_inst = .false.; if (present (show_instance)) s_inst = show_instance
verb = .false.; if (present (verbose)) verb = verbose
if (s_proc .or. s_inst) then
write (u, "(1x,A,':')") "Process data"
if (s_proc) then
process => entry%process
if (associated (process)) then
if (verb) then
call write_separator (u, 2)
call process%write (.false., u)
else
call process%show (u, verbose=.false.)
end if
else
write (u, "(3x,A)") "[not associated]"
end if
end if
if (s_inst) then
instance => entry%instance
if (associated (instance)) then
if (verb) then
call instance%write (u)
else
call instance%write_header (u)
end if
else
write (u, "(3x,A)") "Process instance: [not associated]"
end if
end if
end if
end subroutine entry_write_process_data
@ %def entry_write_process_data
@
\subsection{Entries for alternative environment}
Entries for alternate environments. [No additional components
anymore, so somewhat redundant.]
<<Simulations: types>>=
type, extends (entry_t) :: alt_entry_t
contains
<<Simulations: alt entry: TBP>>
end type alt_entry_t
@ %def alt_entry_t
@ The alternative entries are there to re-evaluate the event, given
momenta, in a different context.
Therefore, we allocate a local process object and use this as the
reference for the local process instance, when initializing the entry.
We temporarily import the [[process]] object into an [[integration_t]]
wrapper, to take advantage of the associated methods. The local
process object is built in the context of the current environment,
here called [[global]]. Then, we initialize the process instance.
The [[master_process]] object contains the integration results to which we
refer when recalculating an event. Therefore, we use this object instead of
the locally built [[process]] when we extract the integration results.
The locally built [[process]] object should be finalized when done. It
remains accessible via the [[event_t]] base object of [[entry]], which
contains pointers to the process and instance.
<<Simulations: alt entry: TBP>>=
procedure :: init_alt => alt_entry_init
<<Simulations: sub interfaces>>=
module subroutine alt_entry_init (entry, process_id, master_process, local)
class(alt_entry_t), intent(inout), target :: entry
type(string_t), intent(in) :: process_id
type(process_t), intent(in), target :: master_process
type(rt_data_t), intent(inout), target :: local
end subroutine alt_entry_init
<<Simulations: procedures>>=
module subroutine alt_entry_init (entry, process_id, master_process, local)
class(alt_entry_t), intent(inout), target :: entry
type(string_t), intent(in) :: process_id
type(process_t), intent(in), target :: master_process
type(rt_data_t), intent(inout), target :: local
type(process_t), pointer :: process
type(process_instance_t), pointer :: process_instance
type(string_t) :: run_id
integer :: i
call msg_message ("Simulate: initializing alternate process setup ...")
run_id = &
local%var_list%get_sval (var_str ("$run_id"))
call local%set_log (var_str ("?rebuild_phase_space"), &
.false., is_known = .true.)
call local%set_log (var_str ("?check_phs_file"), &
.false., is_known = .true.)
call local%set_log (var_str ("?rebuild_grids"), &
.false., is_known = .true.)
call entry%basic_init (local%var_list)
call prepare_local_process (process, process_id, local)
entry%process_id = process_id
entry%run_id = run_id
call entry%import_process_characteristics (process)
allocate (entry%mci_sets (entry%n_mci))
do i = 1, size (entry%mci_sets)
call entry%mci_sets(i)%init (i, master_process)
end do
call entry%import_process_results (master_process)
call entry%prepare_expressions (local)
call prepare_process_instance (process_instance, process, local%model)
call entry%setup_event_transforms (process, local)
call entry%connect (process_instance, local%model, local%process_stack)
call entry%setup_expressions ()
entry%model => process%get_model_ptr ()
call msg_message ("... alternate process setup complete.")
end subroutine alt_entry_init
@ %def alt_entry_init
@ Copy the particle set from the master entry to the alternate entry.
This is the particle set of the hard process.
<<Simulations: alt entry: TBP>>=
procedure :: fill_particle_set => entry_fill_particle_set
<<Simulations: sub interfaces>>=
module subroutine entry_fill_particle_set (alt_entry, entry)
class(alt_entry_t), intent(inout) :: alt_entry
class(entry_t), intent(in), target :: entry
end subroutine entry_fill_particle_set
<<Simulations: procedures>>=
module subroutine entry_fill_particle_set (alt_entry, entry)
class(alt_entry_t), intent(inout) :: alt_entry
class(entry_t), intent(in), target :: entry
type(particle_set_t) :: pset
call entry%get_hard_particle_set (pset)
call alt_entry%set_hard_particle_set (pset)
call pset%final ()
end subroutine entry_fill_particle_set
@ %def particle_set_copy_prt
@
\subsection{The simulation object}
Each simulation object corresponds to an event sample, identified by
the [[sample_id]].
The simulation may cover several processes simultaneously. All
process-specific data, including the event records, are stored in the
[[entry]] subobjects. The [[current]] index indicates which record
was selected last. [[version]] is foreseen to contain a tag on the \whizard\
event file version. It can be
<<Simulations: public>>=
public :: simulation_t
<<Simulations: types>>=
type :: simulation_t
private
type(rt_data_t), pointer :: local => null ()
type(string_t) :: sample_id
logical :: unweighted = .true.
logical :: negative_weights = .false.
logical :: support_resonance_history = .false.
logical :: respect_selection = .true.
integer :: norm_mode = NORM_UNDEFINED
logical :: update_sqme = .false.
logical :: update_weight = .false.
logical :: update_event = .false.
logical :: recover_beams = .false.
logical :: pacify = .false.
integer :: n_max_tries = 10000
integer :: n_prc = 0
integer :: n_alt = 0
logical :: has_integral = .false.
logical :: valid = .false.
real(default) :: integral = 0
real(default) :: error = 0
integer :: version = 1
character(32) :: md5sum_prc = ""
character(32) :: md5sum_cfg = ""
character(32), dimension(:), allocatable :: md5sum_alt
type(entry_t), dimension(:), allocatable :: entry
type(alt_entry_t), dimension(:,:), allocatable :: alt_entry
type(selector_t) :: process_selector
integer :: n_evt_requested = 0
integer :: event_index_offset = 0
logical :: event_index_set = .false.
integer :: event_index = 0
integer :: split_n_evt = 0
integer :: split_n_kbytes = 0
integer :: split_index = 0
type(counter_t) :: counter
class(rng_t), allocatable :: rng
integer :: i_prc = 0
integer :: i_mci = 0
real(default) :: weight = 0
real(default) :: excess = 0
integer :: n_dropped = 0
contains
<<Simulations: simulation: TBP>>
end type simulation_t
@ %def simulation_t
@
\subsubsection{Output of the simulation data}
[[write_config]] writes just the configuration. [[write]]
as a method of the base type [[event_t]]
writes the current event and process instance, depending on options.
<<Simulations: simulation: TBP>>=
procedure :: write => simulation_write
<<Simulations: sub interfaces>>=
module subroutine simulation_write (object, unit, testflag)
class(simulation_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
end subroutine simulation_write
<<Simulations: procedures>>=
module subroutine simulation_write (object, unit, testflag)
class(simulation_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
logical :: pacified
integer :: u, i
u = given_output_unit (unit)
pacified = object%pacify; if (present (testflag)) pacified = testflag
call write_separator (u, 2)
write (u, "(1x,A,A,A)") "Event sample: '", char (object%sample_id), "'"
write (u, "(3x,A,I0)") "Processes = ", object%n_prc
if (object%n_alt > 0) then
write (u, "(3x,A,I0)") "Alt.wgts = ", object%n_alt
end if
write (u, "(3x,A,L1)") "Unweighted = ", object%unweighted
write (u, "(3x,A,A)") "Event norm = ", &
char (event_normalization_string (object%norm_mode))
write (u, "(3x,A,L1)") "Neg. weights = ", object%negative_weights
write (u, "(3x,A,L1)") "Res. history = ", object%support_resonance_history
write (u, "(3x,A,L1)") "Respect sel. = ", object%respect_selection
write (u, "(3x,A,L1)") "Update sqme = ", object%update_sqme
write (u, "(3x,A,L1)") "Update wgt = ", object%update_weight
write (u, "(3x,A,L1)") "Update event = ", object%update_event
write (u, "(3x,A,L1)") "Recov. beams = ", object%recover_beams
write (u, "(3x,A,L1)") "Pacify = ", object%pacify
write (u, "(3x,A,I0)") "Max. tries = ", object%n_max_tries
if (object%has_integral) then
if (pacified) then
write (u, "(3x,A," // FMT_15 // ")") &
"Integral = ", object%integral
write (u, "(3x,A," // FMT_15 // ")") &
"Error = ", object%error
else
write (u, "(3x,A," // FMT_19 // ")") &
"Integral = ", object%integral
write (u, "(3x,A," // FMT_19 // ")") &
"Error = ", object%error
end if
else
write (u, "(3x,A)") "Integral = [undefined]"
end if
write (u, "(3x,A,L1)") "Sim. valid = ", object%valid
write (u, "(3x,A,I0)") "Ev.file ver. = ", object%version
if (object%md5sum_prc /= "") then
write (u, "(3x,A,A,A)") "MD5 sum (proc) = '", object%md5sum_prc, "'"
end if
if (object%md5sum_cfg /= "") then
write (u, "(3x,A,A,A)") "MD5 sum (config) = '", object%md5sum_cfg, "'"
end if
write (u, "(3x,A,I0)") "Events requested = ", object%n_evt_requested
if (object%event_index_offset /= 0) then
write (u, "(3x,A,I0)") "Event index offset= ", object%event_index_offset
end if
if (object%event_index_set) then
write (u, "(3x,A,I0)") "Event index = ", object%event_index
end if
if (object%split_n_evt > 0 .or. object%split_n_kbytes > 0) then
write (u, "(3x,A,I0)") "Events per file = ", object%split_n_evt
write (u, "(3x,A,I0)") "KBytes per file = ", object%split_n_kbytes
write (u, "(3x,A,I0)") "First file index = ", object%split_index
end if
call object%counter%write (u)
call write_separator (u)
if (object%i_prc /= 0) then
write (u, "(1x,A)") "Current event:"
write (u, "(3x,A,I0,A,A)") "Process #", &
object%i_prc, ": ", &
char (object%entry(object%i_prc)%process_id)
write (u, "(3x,A,I0)") "MCI set #", object%i_mci
write (u, "(3x,A," // FMT_19 // ")") "Weight = ", object%weight
if (.not. vanishes (object%excess)) &
write (u, "(3x,A," // FMT_19 // ")") "Excess = ", object%excess
write (u, "(3x,A,I0)") "Zero-weight events dropped = ", object%n_dropped
else
write (u, "(1x,A,I0,A,A)") "Current event: [undefined]"
end if
call write_separator (u)
if (allocated (object%rng)) then
call object%rng%write (u)
else
write (u, "(3x,A)") "Random-number generator: [undefined]"
end if
if (allocated (object%entry)) then
do i = 1, size (object%entry)
if (i == 1) then
call write_separator (u, 2)
else
call write_separator (u)
end if
write (u, "(1x,A,I0,A)") "Process #", i, ":"
call object%entry(i)%write_config (u, pacified)
end do
end if
call write_separator (u, 2)
end subroutine simulation_write
@ %def simulation_write
@ Write the current event record. If an explicit index is given,
write that event record.
We implement writing to [[unit]] (event contents / debugging format)
and writing to an [[eio]] event stream (storage). We include a [[testflag]]
in order to suppress numerical noise in the testsuite.
<<Simulations: simulation: TBP>>=
generic :: write_event => write_event_unit
procedure :: write_event_unit => simulation_write_event_unit
<<Simulations: sub interfaces>>=
module subroutine simulation_write_event_unit &
(object, unit, i_prc, verbose, testflag)
class(simulation_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer, intent(in), optional :: i_prc
logical, intent(in), optional :: testflag
end subroutine simulation_write_event_unit
<<Simulations: procedures>>=
module subroutine simulation_write_event_unit &
(object, unit, i_prc, verbose, testflag)
class(simulation_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer, intent(in), optional :: i_prc
logical, intent(in), optional :: testflag
logical :: pacified
integer :: current
pacified = .false.; if (present(testflag)) pacified = testflag
pacified = pacified .or. object%pacify
if (present (i_prc)) then
current = i_prc
else
current = object%i_prc
end if
if (current > 0) then
call object%entry(current)%write (unit, verbose = verbose, &
testflag = pacified)
else
call msg_fatal ("Simulation: write event: no process selected")
end if
end subroutine simulation_write_event_unit
@ %def simulation_write_event
@ This writes one of the alternate events, if allocated.
<<Simulations: simulation: TBP>>=
procedure :: write_alt_event => simulation_write_alt_event
<<Simulations: sub interfaces>>=
module subroutine simulation_write_alt_event (object, unit, j_alt, i_prc, &
verbose, testflag)
class(simulation_t), intent(in) :: object
integer, intent(in), optional :: unit
integer, intent(in), optional :: j_alt
integer, intent(in), optional :: i_prc
logical, intent(in), optional :: verbose
logical, intent(in), optional :: testflag
end subroutine simulation_write_alt_event
<<Simulations: procedures>>=
module subroutine simulation_write_alt_event (object, unit, j_alt, i_prc, &
verbose, testflag)
class(simulation_t), intent(in) :: object
integer, intent(in), optional :: unit
integer, intent(in), optional :: j_alt
integer, intent(in), optional :: i_prc
logical, intent(in), optional :: verbose
logical, intent(in), optional :: testflag
integer :: i, j
if (present (j_alt)) then
j = j_alt
else
j = 1
end if
if (present (i_prc)) then
i = i_prc
else
i = object%i_prc
end if
if (i > 0) then
if (j> 0 .and. j <= object%n_alt) then
call object%alt_entry(i,j)%write (unit, verbose = verbose, &
testflag = testflag)
else
call msg_fatal ("Simulation: write alternate event: out of range")
end if
else
call msg_fatal ("Simulation: write alternate event: no process selected")
end if
end subroutine simulation_write_alt_event
@ %def simulation_write_alt_event
@ This writes the contents of the resonant subprocess set in the current event
record.
<<Simulations: simulation: TBP>>=
procedure :: write_resonant_subprocess_data &
=> simulation_write_resonant_subprocess_data
<<Simulations: sub interfaces>>=
module subroutine simulation_write_resonant_subprocess_data &
(object, unit, i_prc)
class(simulation_t), intent(in) :: object
integer, intent(in), optional :: unit
integer, intent(in), optional :: i_prc
end subroutine simulation_write_resonant_subprocess_data
<<Simulations: procedures>>=
module subroutine simulation_write_resonant_subprocess_data &
(object, unit, i_prc)
class(simulation_t), intent(in) :: object
integer, intent(in), optional :: unit
integer, intent(in), optional :: i_prc
integer :: i
if (present (i_prc)) then
i = i_prc
else
i = object%i_prc
end if
call object%entry(i)%write_resonant_subprocess_data (unit)
end subroutine simulation_write_resonant_subprocess_data
@ %def simulation_write_resonant_subprocess_data
@ The same for the master process, as an additional debugging aid.
<<Simulations: simulation: TBP>>=
procedure :: write_process_data &
=> simulation_write_process_data
<<Simulations: sub interfaces>>=
module subroutine simulation_write_process_data &
(object, unit, i_prc, &
show_process, show_instance, verbose)
class(simulation_t), intent(in) :: object
integer, intent(in), optional :: unit
integer, intent(in), optional :: i_prc
logical, intent(in), optional :: show_process
logical, intent(in), optional :: show_instance
logical, intent(in), optional :: verbose
end subroutine simulation_write_process_data
<<Simulations: procedures>>=
module subroutine simulation_write_process_data &
(object, unit, i_prc, &
show_process, show_instance, verbose)
class(simulation_t), intent(in) :: object
integer, intent(in), optional :: unit
integer, intent(in), optional :: i_prc
logical, intent(in), optional :: show_process
logical, intent(in), optional :: show_instance
logical, intent(in), optional :: verbose
integer :: i
if (present (i_prc)) then
i = i_prc
else
i = object%i_prc
end if
call object%entry(i)%write_process_data &
(unit, show_process, show_instance, verbose)
end subroutine simulation_write_process_data
@ %def simulation_write_process_data
@ Write the actual efficiency of the simulation run. We get the total
number of events stored in the simulation counter and compare this
with the total number of calls stored in the event entries.
In order not to miscount samples that are partly read from file, use
the [[generated]] counter, not the [[total]] counter.
<<Simulations: simulation: TBP>>=
procedure :: show_efficiency => simulation_show_efficiency
<<Simulations: sub interfaces>>=
module subroutine simulation_show_efficiency (simulation)
class(simulation_t), intent(inout) :: simulation
end subroutine simulation_show_efficiency
<<Simulations: procedures>>=
module subroutine simulation_show_efficiency (simulation)
class(simulation_t), intent(inout) :: simulation
integer :: n_events, n_calls
real(default) :: eff
n_events = simulation%counter%generated
n_calls = sum (simulation%entry%get_actual_calls_total ())
if (n_calls > 0) then
eff = real (n_events, kind=default) / n_calls
write (msg_buffer, "(A,1x,F6.2,1x,A)") &
"Events: actual unweighting efficiency =", 100 * eff, "%"
call msg_message ()
end if
end subroutine simulation_show_efficiency
@ %def simulation_show_efficiency
@ Compute the checksum of the process set. We retrieve the MD5 sums
of all processes. This depends only on the process definitions, while
parameters are not considered. The configuration checksum is
retrieved from the MCI records in the process objects and furthermore
includes beams, parameters, integration results, etc., so matching the
latter should guarantee identical physics.
<<Simulations: simulation: TBP>>=
procedure :: compute_md5sum => simulation_compute_md5sum
<<Simulations: sub interfaces>>=
module subroutine simulation_compute_md5sum (simulation)
class(simulation_t), intent(inout) :: simulation
end subroutine simulation_compute_md5sum
<<Simulations: procedures>>=
module subroutine simulation_compute_md5sum (simulation)
class(simulation_t), intent(inout) :: simulation
type(process_t), pointer :: process
type(string_t) :: buffer
integer :: j, i, n_mci, i_mci, n_component, i_component
if (simulation%md5sum_prc == "") then
buffer = ""
do i = 1, simulation%n_prc
if (.not. simulation%entry(i)%valid) cycle
process => simulation%entry(i)%get_process_ptr ()
if (associated (process)) then
n_component = process%get_n_components ()
do i_component = 1, n_component
if (process%has_matrix_element (i_component)) then
buffer = buffer // process%get_md5sum_prc (i_component)
end if
end do
end if
end do
simulation%md5sum_prc = md5sum (char (buffer))
end if
if (simulation%md5sum_cfg == "") then
buffer = ""
do i = 1, simulation%n_prc
if (.not. simulation%entry(i)%valid) cycle
process => simulation%entry(i)%get_process_ptr ()
if (associated (process)) then
n_mci = process%get_n_mci ()
do i_mci = 1, n_mci
buffer = buffer // process%get_md5sum_mci (i_mci)
end do
end if
end do
simulation%md5sum_cfg = md5sum (char (buffer))
end if
do j = 1, simulation%n_alt
if (simulation%md5sum_alt(j) == "") then
buffer = ""
do i = 1, simulation%n_prc
process => simulation%alt_entry(i,j)%get_process_ptr ()
if (associated (process)) then
buffer = buffer // process%get_md5sum_cfg ()
end if
end do
simulation%md5sum_alt(j) = md5sum (char (buffer))
end if
end do
end subroutine simulation_compute_md5sum
@ %def simulation_compute_md5sum
@
\subsubsection{Simulation-object finalizer}
<<Simulations: simulation: TBP>>=
procedure :: final => simulation_final
<<Simulations: sub interfaces>>=
module subroutine simulation_final (object)
class(simulation_t), intent(inout) :: object
end subroutine simulation_final
<<Simulations: procedures>>=
module subroutine simulation_final (object)
class(simulation_t), intent(inout) :: object
integer :: i, j
if (allocated (object%entry)) then
do i = 1, size (object%entry)
call object%entry(i)%final ()
end do
end if
if (allocated (object%alt_entry)) then
do j = 1, size (object%alt_entry, 2)
do i = 1, size (object%alt_entry, 1)
call object%alt_entry(i,j)%final ()
end do
end do
end if
if (allocated (object%rng)) call object%rng%final ()
end subroutine simulation_final
@ %def simulation_final
@
\subsubsection{Simulation-object initialization}
We can deduce all data from the given list of
process IDs and the global data set. The process objects are taken
from the stack. Once the individual integrals are known, we add them (and the
errors), to get the sample integral.
If there are alternative environments, we suspend initialization for
setting up alternative process objects, then restore the master
process and its parameters. The generator or rescanner can then
switch rapidly between processes.
If [[integrate]] is set, we make sure that all affected processes are
integrated before simulation. This is necessary if we want to actually
generate events. If [[integrate]] is unset, we do not need the integral
because we just rescan existing events. In that case, we just need compiled
matrix elements.
If [[generate]] is set, we prepare for actually generating events. Otherwise,
we may only read and rescan events.
<<Simulations: simulation: TBP>>=
procedure :: init => simulation_init
<<Simulations: sub interfaces>>=
module subroutine simulation_init (simulation, &
process_id, integrate, generate, local, global, alt_env)
class(simulation_t), intent(out), target :: simulation
type(string_t), dimension(:), intent(in) :: process_id
logical, intent(in) :: integrate, generate
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
type(rt_data_t), dimension(:), intent(inout), optional, target :: alt_env
end subroutine simulation_init
<<Simulations: procedures>>=
module subroutine simulation_init (simulation, &
process_id, integrate, generate, local, global, alt_env)
class(simulation_t), intent(out), target :: simulation
type(string_t), dimension(:), intent(in) :: process_id
logical, intent(in) :: integrate, generate
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), optional, target :: global
type(rt_data_t), dimension(:), intent(inout), optional, target :: alt_env
class(rng_factory_t), allocatable :: rng_factory
integer :: next_rng_seed
type(string_t) :: norm_string, version_string
logical :: use_process
integer :: i, j
type(string_t) :: sample_suffix
<<Simulations: simulation init: extra variables>>
sample_suffix = ""
<<Simulations: simulation init: extra init>>
simulation%local => local
simulation%sample_id = &
local%get_sval (var_str ("$sample"))
simulation%unweighted = &
local%get_lval (var_str ("?unweighted"))
simulation%negative_weights = &
local%get_lval (var_str ("?negative_weights"))
simulation%support_resonance_history = &
local%get_lval (var_str ("?resonance_history"))
simulation%respect_selection = &
local%get_lval (var_str ("?sample_select"))
version_string = &
local%get_sval (var_str ("$event_file_version"))
norm_string = &
local%get_sval (var_str ("$sample_normalization"))
simulation%norm_mode = &
event_normalization_mode (norm_string, simulation%unweighted)
simulation%pacify = &
local%get_lval (var_str ("?sample_pacify"))
simulation%event_index_offset = &
local%get_ival (var_str ("event_index_offset"))
simulation%n_max_tries = &
local%get_ival (var_str ("sample_max_tries"))
simulation%split_n_evt = &
local%get_ival (var_str ("sample_split_n_evt"))
simulation%split_n_kbytes = &
local%get_ival (var_str ("sample_split_n_kbytes"))
simulation%split_index = &
local%get_ival (var_str ("sample_split_index"))
simulation%update_sqme = &
local%get_lval (var_str ("?update_sqme"))
simulation%update_weight = &
local%get_lval (var_str ("?update_weight"))
simulation%update_event = &
local%get_lval (var_str ("?update_event"))
simulation%recover_beams = &
local%get_lval (var_str ("?recover_beams"))
simulation%counter%reproduce_xsection = &
local%get_lval (var_str ("?check_event_weights_against_xsection"))
use_process = &
integrate .or. generate &
.or. simulation%update_sqme &
.or. simulation%update_weight &
.or. simulation%update_event &
.or. present (alt_env)
select case (size (process_id))
case (0)
call msg_error ("Simulation: no process selected")
case (1)
write (msg_buffer, "(A,A,A)") &
"Starting simulation for process '", &
char (process_id(1)), "'"
call msg_message ()
case default
write (msg_buffer, "(A,A,A)") &
"Starting simulation for processes '", &
char (process_id(1)), "' etc."
call msg_message ()
end select
select case (char (version_string))
case ("", "2.2.4")
simulation%version = 2
case ("2.2")
simulation%version = 1
case default
simulation%version = 0
end select
if (simulation%version == 0) then
call msg_fatal ("Event file format '" &
// char (version_string) &
// "' is not compatible with this version.")
end if
simulation%n_prc = size (process_id)
allocate (simulation%entry (simulation%n_prc))
if (present (alt_env)) then
simulation%n_alt = size (alt_env)
do i = 1, simulation%n_prc
call simulation%entry(i)%init (process_id(i), &
use_process, integrate, generate, &
simulation%update_sqme, &
simulation%support_resonance_history, &
local, global, simulation%n_alt)
if (signal_is_pending ()) return
end do
simulation%valid = any (simulation%entry%valid)
if (.not. simulation%valid) then
call msg_error ("Simulate: no process has a valid matrix element.")
return
end if
call simulation%update_processes ()
allocate (simulation%alt_entry (simulation%n_prc, simulation%n_alt))
allocate (simulation%md5sum_alt (simulation%n_alt))
simulation%md5sum_alt = ""
do j = 1, simulation%n_alt
do i = 1, simulation%n_prc
call simulation%alt_entry(i,j)%init_alt (process_id(i), &
simulation%entry(i)%get_process_ptr (), alt_env(j))
if (signal_is_pending ()) return
end do
end do
call simulation%restore_processes ()
else
do i = 1, simulation%n_prc
call simulation%entry(i)%init &
(process_id(i), &
use_process, integrate, generate, &
simulation%update_sqme, &
simulation%support_resonance_history, &
local, global)
call simulation%entry(i)%determine_if_powheg_matching ()
if (signal_is_pending ()) return
if (simulation%entry(i)%is_nlo ()) &
call simulation%entry(i)%setup_additional_entries ()
end do
simulation%valid = any (simulation%entry%valid)
if (.not. simulation%valid) then
call msg_error ("Simulate: " &
// "no process has a valid matrix element.")
return
end if
end if
!!! if this becomes conditional, some ref files will need update (seed change)
! if (generate) then
call dispatch_rng_factory (rng_factory, local%var_list, next_rng_seed)
call update_rng_seed_in_var_list (local%var_list, next_rng_seed)
call rng_factory%make (simulation%rng)
<<Simulations: simulation init: extra RNG init>>
! end if
if (all (simulation%entry%has_integral)) then
simulation%integral = sum (simulation%entry%integral)
simulation%error = sqrt (sum (simulation%entry%error ** 2))
simulation%has_integral = .true.
if (integrate .and. generate) then
do i = 1, simulation%n_prc
if (simulation%entry(i)%integral < 0 .and. .not. &
simulation%negative_weights) then
call msg_fatal ("Integral of process '" // &
char (process_id (i)) // "'is negative.")
end if
end do
end if
else
if (integrate .and. generate) &
call msg_error ("Simulation contains undefined integrals.")
end if
if (simulation%integral > 0 .or. &
(simulation%integral < 0 .and. simulation%negative_weights)) then
simulation%valid = .true.
else if (generate) then
call msg_error ("Simulate: " &
// "sum of process integrals must be positive; skipping.")
simulation%valid = .false.
else
simulation%valid = .true.
end if
if (simulation%sample_id == "") then
simulation%sample_id = simulation%get_default_sample_name ()
end if
simulation%sample_id = simulation%sample_id // sample_suffix
if (simulation%valid) call simulation%compute_md5sum ()
end subroutine simulation_init
@ %def simulation_init
@ The RNG initialization depends on serial/MPI mode.
<<Simulations: simulation init: extra variables>>=
<<MPI: Simulations: simulation init: extra variables>>=
integer :: rank, n_size
<<Simulations: simulation init: extra init>>=
<<MPI: Simulations: simulation init: extra init>>=
call mpi_get_comm_id (n_size, rank)
if (n_size > 1) then
sample_suffix = var_str ("_") // str (rank)
end if
<<Simulations: simulation init: extra RNG init>>=
<<MPI: Simulations: simulation init: extra RNG init>>=
do i = 2, rank + 1
select type (rng => simulation%rng)
type is (rng_stream_t)
call rng%next_substream ()
if (i == rank) &
call msg_message ("Simulate: Advance RNG for parallel event generation")
class default
call rng%write ()
call msg_bug ("Parallel event generation: random-number generator &
&must be 'rng_stream'.")
end select
end do
@ The number of events that we want to simulate is determined by the
settings of [[n_events]], [[luminosity]], and [[?unweighted]]. For
weighted events, we take [[n_events]] at face value as the number of
matrix element calls. For unweighted events, if the process is a
decay, [[n_events]] is the number of unweighted events. In these
cases, the luminosity setting is ignored.
For unweighted events with a scattering process, we calculate the
event number that corresponds to the luminosity, given the current
value of the integral. We then compare this with [[n_events]] and
choose the larger number.
<<Simulations: simulation: TBP>>=
procedure :: compute_n_events => simulation_compute_n_events
<<Simulations: sub interfaces>>=
module subroutine simulation_compute_n_events (simulation, n_events)
class(simulation_t), intent(in) :: simulation
integer, intent(out) :: n_events
end subroutine simulation_compute_n_events
<<Simulations: procedures>>=
module subroutine simulation_compute_n_events (simulation, n_events)
class(simulation_t), intent(in) :: simulation
integer, intent(out) :: n_events
real(default) :: lumi, x_events_lumi
integer :: n_events_lumi
logical :: is_scattering
n_events = &
simulation%local%get_ival (var_str ("n_events"))
lumi = &
simulation%local%get_rval (var_str ("luminosity"))
if (simulation%unweighted) then
is_scattering = simulation%entry(1)%n_in == 2
if (is_scattering) then
x_events_lumi = abs (simulation%integral * lumi)
if (x_events_lumi < huge (n_events)) then
n_events_lumi = nint (x_events_lumi)
else
call msg_message ("Simulation: luminosity too large, &
&limiting number of events")
n_events_lumi = huge (n_events)
end if
if (n_events_lumi > n_events) then
call msg_message ("Simulation: using n_events as computed from &
&luminosity value")
n_events = n_events_lumi
else
write (msg_buffer, "(A,1x,I0)") &
"Simulation: requested number of events =", n_events
call msg_message ()
if (.not. vanishes (simulation%integral)) then
write (msg_buffer, "(A,1x,ES11.4)") &
" corr. to luminosity [fb-1] = ", &
n_events / simulation%integral
call msg_message ()
end if
end if
end if
end if
end subroutine simulation_compute_n_events
@ %def simulation_compute_n_events
@ Configuration of the OpenMP parameters, in case OpenMP is active. We use
the settings accessible via the local environment.
<<Simulations: simulation: TBP>>=
procedure :: setup_openmp => simulation_setup_openmp
<<Simulations: sub interfaces>>=
module subroutine simulation_setup_openmp (simulation)
class(simulation_t), intent(inout) :: simulation
end subroutine simulation_setup_openmp
<<Simulations: procedures>>=
module subroutine simulation_setup_openmp (simulation)
class(simulation_t), intent(inout) :: simulation
call openmp_set_num_threads_verbose &
(simulation%local%get_ival (var_str ("openmp_num_threads")), &
simulation%local%get_lval (var_str ("?openmp_logging")))
end subroutine simulation_setup_openmp
@ %def simulation_setup_openmp
@ Configuration of the event-stream array -- i.e., the setup of
output file formats.
<<Simulations: simulation: TBP>>=
procedure :: prepare_event_streams => simulation_prepare_event_streams
<<Simulations: sub interfaces>>=
module subroutine simulation_prepare_event_streams (sim, es_array)
class(simulation_t), intent(inout) :: sim
type(event_stream_array_t), intent(out) :: es_array
end subroutine simulation_prepare_event_streams
<<Simulations: procedures>>=
module subroutine simulation_prepare_event_streams (sim, es_array)
class(simulation_t), intent(inout) :: sim
type(event_stream_array_t), intent(out) :: es_array
integer :: n_events
logical :: rebuild_events, read_raw, write_raw
integer :: checkpoint, callback
integer :: n_fmt
type(event_sample_data_t) :: data
type(string_t), dimension(:), allocatable :: sample_fmt
n_events = &
sim%n_evt_requested
rebuild_events = &
sim%local%get_lval (var_str ("?rebuild_events"))
read_raw = &
sim%local%get_lval (var_str ("?read_raw")) .and. .not. rebuild_events
write_raw = &
sim%local%get_lval (var_str ("?write_raw"))
checkpoint = &
sim%local%get_ival (var_str ("checkpoint"))
callback = &
sim%local%get_ival (var_str ("event_callback_interval"))
if (read_raw) then
inquire (file = char (sim%sample_id) // ".evx", exist = read_raw)
end if
if (allocated (sim%local%sample_fmt)) then
n_fmt = size (sim%local%sample_fmt)
else
n_fmt = 0
end if
data = sim%get_data ()
data%n_evt = n_events
data%nlo_multiplier = sim%get_n_nlo_entries (1)
if (read_raw) then
allocate (sample_fmt (n_fmt))
if (n_fmt > 0) sample_fmt = sim%local%sample_fmt
call es_array%init (sim%sample_id, &
sample_fmt, sim%local, &
data = data, &
input = var_str ("raw"), &
allow_switch = write_raw, &
checkpoint = checkpoint, &
callback = callback)
else if (write_raw) then
allocate (sample_fmt (n_fmt + 1))
if (n_fmt > 0) sample_fmt(:n_fmt) = sim%local%sample_fmt
sample_fmt(n_fmt+1) = var_str ("raw")
call es_array%init (sim%sample_id, &
sample_fmt, sim%local, &
data = data, &
checkpoint = checkpoint, &
callback = callback)
else if (allocated (sim%local%sample_fmt) &
.or. checkpoint > 0 &
.or. callback > 0) then
allocate (sample_fmt (n_fmt))
if (n_fmt > 0) sample_fmt = sim%local%sample_fmt
call es_array%init (sim%sample_id, &
sample_fmt, sim%local, &
data = data, &
checkpoint = checkpoint, &
callback = callback)
end if
end subroutine simulation_prepare_event_streams
@ %def simulation_prepare_event_streams
@
<<Simulations: simulation: TBP>>=
procedure :: get_n_nlo_entries => simulation_get_n_nlo_entries
<<Simulations: sub interfaces>>=
module function simulation_get_n_nlo_entries &
(simulation, i_prc) result (n_extra)
class(simulation_t), intent(in) :: simulation
integer, intent(in) :: i_prc
integer :: n_extra
end function simulation_get_n_nlo_entries
<<Simulations: procedures>>=
module function simulation_get_n_nlo_entries &
(simulation, i_prc) result (n_extra)
class(simulation_t), intent(in) :: simulation
integer, intent(in) :: i_prc
integer :: n_extra
n_extra = simulation%entry(i_prc)%count_nlo_entries ()
end function simulation_get_n_nlo_entries
@ %def simulation_get_n_nlo_entries
@ Initialize the process selector, using the entry integrals as process
weights.
<<Simulations: simulation: TBP>>=
procedure :: init_process_selector => simulation_init_process_selector
<<Simulations: sub interfaces>>=
module subroutine simulation_init_process_selector (simulation)
class(simulation_t), intent(inout) :: simulation
end subroutine simulation_init_process_selector
<<Simulations: procedures>>=
module subroutine simulation_init_process_selector (simulation)
class(simulation_t), intent(inout) :: simulation
integer :: i
if (simulation%has_integral) then
call simulation%process_selector%init (simulation%entry%integral, &
negative_weights = simulation%negative_weights)
do i = 1, simulation%n_prc
associate (entry => simulation%entry(i))
if (.not. entry%valid) then
call msg_warning ("Process '" // char (entry%process_id) // &
"': matrix element vanishes, no events can be generated.")
cycle
end if
call entry%init_mci_selector (simulation%negative_weights)
entry%process_weight = simulation%process_selector%get_weight (i)
end associate
end do
end if
end subroutine simulation_init_process_selector
@ %def simulation_init_process_selector
@ Select a process, using the random-number generator.
<<Simulations: simulation: TBP>>=
procedure :: select_prc => simulation_select_prc
<<Simulations: sub interfaces>>=
module function simulation_select_prc (simulation) result (i_prc)
class(simulation_t), intent(inout) :: simulation
integer :: i_prc
end function simulation_select_prc
<<Simulations: procedures>>=
module function simulation_select_prc (simulation) result (i_prc)
class(simulation_t), intent(inout) :: simulation
integer :: i_prc
call simulation%process_selector%generate (simulation%rng, i_prc)
end function simulation_select_prc
@ %def simulation_select_prc
@ Select a MCI set for the selected process.
<<Simulations: simulation: TBP>>=
procedure :: select_mci => simulation_select_mci
<<Simulations: sub interfaces>>=
module function simulation_select_mci (simulation) result (i_mci)
class(simulation_t), intent(inout) :: simulation
integer :: i_mci
end function simulation_select_mci
<<Simulations: procedures>>=
module function simulation_select_mci (simulation) result (i_mci)
class(simulation_t), intent(inout) :: simulation
integer :: i_mci
i_mci = 0
if (simulation%i_prc /= 0) then
i_mci = simulation%entry(simulation%i_prc)%select_mci ()
end if
end function simulation_select_mci
@ %def simulation_select_mci
@
\subsubsection{Generate-event loop}
The requested number of events should be set by this, in time for the
event-array initializers that may use this number.
<<Simulations: simulation: TBP>>=
procedure :: set_n_events_requested => simulation_set_n_events_requested
procedure :: get_n_events_requested => simulation_get_n_events_requested
<<Simulations: sub interfaces>>=
module subroutine simulation_set_n_events_requested (simulation, n)
class(simulation_t), intent(inout) :: simulation
integer, intent(in) :: n
end subroutine simulation_set_n_events_requested
module function simulation_get_n_events_requested (simulation) result (n)
class(simulation_t), intent(in) :: simulation
integer :: n
end function simulation_get_n_events_requested
<<Simulations: procedures>>=
module subroutine simulation_set_n_events_requested (simulation, n)
class(simulation_t), intent(inout) :: simulation
integer, intent(in) :: n
simulation%n_evt_requested = n
end subroutine simulation_set_n_events_requested
module function simulation_get_n_events_requested (simulation) result (n)
class(simulation_t), intent(in) :: simulation
integer :: n
n = simulation%n_evt_requested
end function simulation_get_n_events_requested
@ %def simulation_set_n_events_requested
@ %def simulation_get_n_events_requested
@ Generate the number of events that has been set by
[[simulation_set_n_events_requested]]. First select a process and a component
set, then generate an event for that process and factorize the quantum state.
The pair of random numbers can be used for factorization.
When generating events, we drop all configurations where the event is
marked as incomplete. This happens if the event fails cuts. In fact,
such events are dropped already by the sampler if unweighting is in
effect, so this can happen only for weighted events. By setting a
limit given by [[sample_max_tries]] (user parameter), we can avoid an
endless loop.
The [[begin_it]] and [[end_it]] limits are equal to 1 and the number of
events, repspectively, in serial mode, but differ for MPI mode.
TODO: When reading from file, event transforms cannot be applied because the
process instance will not be complete. (?)
<<Simulations: simulation: TBP>>=
procedure :: generate => simulation_generate
<<Simulations: sub interfaces>>=
module subroutine simulation_generate (simulation, es_array)
class(simulation_t), intent(inout), target :: simulation
type(event_stream_array_t), intent(inout), optional :: es_array
end subroutine simulation_generate
<<Simulations: procedures>>=
module subroutine simulation_generate (simulation, es_array)
class(simulation_t), intent(inout), target :: simulation
type(event_stream_array_t), intent(inout), optional :: es_array
integer :: begin_it, end_it
integer :: i, j, k
call simulation%before_first_event (begin_it, end_it, es_array)
do i = begin_it, end_it
call simulation%next_event (es_array)
end do
call simulation%after_last_event (begin_it, end_it)
end subroutine simulation_generate
@ %def simulation_generate
@ The header of the event loop: with all necessary information present in the
[[simulation]] and [[es_array]] objects, and given a number of events [[n]] to
generate, we prepare for actually generating/reading/writing events.
The procedure returns the real iteration bounds [[begin_it]] and [[end_it]]
for the event loop. This is nontrivial only for MPI; in serial mode those are
equal to 1 and to [[n_events]], respectively.
<<Simulations: simulation: TBP>>=
procedure :: before_first_event => simulation_before_first_event
<<Simulations: sub interfaces>>=
module subroutine simulation_before_first_event (simulation, &
begin_it, end_it, es_array)
class(simulation_t), intent(inout), target :: simulation
integer, intent(out) :: begin_it
integer, intent(out) :: end_it
type(event_stream_array_t), intent(inout), optional :: es_array
end subroutine simulation_before_first_event
<<Simulations: procedures>>=
module subroutine simulation_before_first_event (simulation, &
begin_it, end_it, es_array)
class(simulation_t), intent(inout), target :: simulation
integer, intent(out) :: begin_it
integer, intent(out) :: end_it
type(event_stream_array_t), intent(inout), optional :: es_array
integer :: n_evt_requested
logical :: has_input
integer :: n_events_print
logical :: is_leading_order
logical :: is_weighted
logical :: is_polarized
n_evt_requested = simulation%n_evt_requested
n_events_print = n_evt_requested * simulation%get_n_nlo_entries (1)
is_leading_order = (n_events_print == n_evt_requested)
has_input = .false.
if (present (es_array)) has_input = es_array%has_input ()
is_weighted = .not. simulation%entry(1)%config%unweighted
is_polarized = simulation%entry(1)%config%factorization_mode &
/= FM_IGNORE_HELICITY
call simulation%startup_message_generate ( &
has_input = has_input, &
is_weighted = is_weighted, &
is_polarized = is_polarized, &
is_leading_order = is_leading_order, &
n_events = n_events_print)
call simulation%entry%set_n (n_evt_requested)
if (simulation%n_alt > 0) call simulation%alt_entry%set_n (n_evt_requested)
call simulation%init_event_index ()
begin_it = 1
end_it = n_evt_requested
<<Simulations: simulation generate: extra init>>
end subroutine simulation_before_first_event
@ %def simulation_before_first_event
@ Keep the user informed:
<<Simulations: simulation: TBP>>=
procedure, private :: startup_message_generate &
=> simulation_startup_message_generate
<<Simulations: sub interfaces>>=
module subroutine simulation_startup_message_generate (simulation, &
has_input, is_weighted, is_polarized, is_leading_order, n_events)
class(simulation_t), intent(in) :: simulation
logical, intent(in) :: has_input
logical, intent(in) :: is_weighted
logical, intent(in) :: is_polarized
logical, intent(in) :: is_leading_order
integer, intent(in) :: n_events
end subroutine simulation_startup_message_generate
<<Simulations: procedures>>=
module subroutine simulation_startup_message_generate (simulation, &
has_input, is_weighted, is_polarized, is_leading_order, n_events)
class(simulation_t), intent(in) :: simulation
logical, intent(in) :: has_input
logical, intent(in) :: is_weighted
logical, intent(in) :: is_polarized
logical, intent(in) :: is_leading_order
integer, intent(in) :: n_events
type(string_t) :: str1, str2, str3, str4
if (has_input) then
str1 = "Events: reading"
else
str1 = "Events: generating"
end if
if (is_weighted) then
str2 = "weighted"
else
str2 = "unweighted"
end if
if (is_polarized) then
str3 = ", polarized"
else
str3 = ", unpolarized"
end if
str4 = ""
if (.not. is_leading_order) str4 = " NLO"
write (msg_buffer, "(A,1X,I0,1X,A,1X,A)") char (str1), n_events, &
char (str2) // char(str3) // char(str4), "events ..."
call msg_message ()
write (msg_buffer, "(A,1x,A)") "Events: event normalization mode", &
char (event_normalization_string (simulation%norm_mode))
call msg_message ()
end subroutine simulation_startup_message_generate
@ %def simulation_startup_message_generate
@
The body of the event loop: generate and process a single event.
Optionally transfer the current event to one of the provided event handles,
for in and/or output streams. This works for any stream for which the I/O
stream type matches the event-handle type.
<<Simulations: simulation: TBP>>=
procedure :: next_event => simulation_next_event
<<Simulations: sub interfaces>>=
module subroutine simulation_next_event &
(simulation, es_array, event_handle_out, event_handle_in)
class(simulation_t), intent(inout) :: simulation
type(event_stream_array_t), intent(inout), optional :: es_array
class(event_handle_t), intent(inout), optional :: event_handle_out
class(event_handle_t), intent(inout), optional :: event_handle_in
end subroutine simulation_next_event
<<Simulations: procedures>>=
module subroutine simulation_next_event &
(simulation, es_array, event_handle_out, event_handle_in)
class(simulation_t), intent(inout) :: simulation
type(event_stream_array_t), intent(inout), optional :: es_array
class(event_handle_t), intent(inout), optional :: event_handle_out
class(event_handle_t), intent(inout), optional :: event_handle_in
type(entry_t), pointer :: current_entry
logical :: generate_new
logical :: passed
integer :: j, k
call simulation%increment_event_index ()
if (present (es_array)) then
call simulation%read_event &
(es_array, .true., generate_new, event_handle_in)
else
generate_new = .true.
end if
if (generate_new) then
simulation%i_prc = simulation%select_prc ()
simulation%i_mci = simulation%select_mci ()
associate (entry => simulation%entry(simulation%i_prc))
entry%instance%i_mci = simulation%i_mci
call entry%set_active_real_components ()
current_entry => entry%get_first ()
do k = 1, current_entry%count_nlo_entries ()
if (k > 1) then
current_entry => current_entry%get_next ()
current_entry%particle_set => current_entry%first%particle_set
current_entry%particle_set_is_valid &
= current_entry%first%particle_set_is_valid
end if
do j = 1, simulation%n_max_tries
if (.not. current_entry%valid) call msg_warning &
("Process '" // char (current_entry%process_id) // "': " // &
"matrix element vanishes, no events can be generated.")
call current_entry%generate (simulation%i_mci, i_nlo = k)
if (signal_is_pending ()) return
call simulation%counter%record_mean_and_variance &
(current_entry%weight_prc, k)
if (current_entry%has_valid_particle_set ()) exit
end do
end do
if (entry%is_nlo ()) call entry%reset_nlo_counter ()
if (.not. entry%has_valid_particle_set ()) then
write (msg_buffer, "(A,I0,A)") "Simulation: failed to &
&generate valid event after ", &
simulation%n_max_tries, " tries (sample_max_tries)"
call msg_fatal ()
end if
current_entry => entry%get_first ()
do k = 1, current_entry%count_nlo_entries ()
if (k > 1) current_entry => current_entry%get_next ()
call current_entry%set_index (simulation%get_event_index ())
call current_entry%evaluate_expressions ()
end do
if (signal_is_pending ()) return
simulation%n_dropped = entry%get_n_dropped ()
if (entry%passed_selection ()) then
simulation%weight = entry%get_weight_ref ()
simulation%excess = entry%get_excess_prc ()
end if
call simulation%counter%record &
(simulation%weight, simulation%excess, simulation%n_dropped)
call entry%record (simulation%i_mci)
end associate
else
associate (entry => simulation%entry(simulation%i_prc))
call simulation%set_event_index (entry%get_index ())
call entry%accept_sqme_ref ()
call entry%accept_weight_ref ()
call entry%check ()
call entry%evaluate_expressions ()
if (signal_is_pending ()) return
simulation%n_dropped = entry%get_n_dropped ()
if (entry%passed_selection ()) then
simulation%weight = entry%get_weight_ref ()
simulation%excess = entry%get_excess_prc ()
end if
call simulation%counter%record &
(simulation%weight, simulation%excess, simulation%n_dropped, &
from_file=.true.)
call entry%record (simulation%i_mci, from_file=.true.)
end associate
end if
call simulation%calculate_alt_entries ()
if (simulation%pacify) call pacify (simulation)
if (signal_is_pending ()) return
if (simulation%respect_selection) then
passed = simulation%entry(simulation%i_prc)%passed_selection ()
else
passed = .true.
end if
if (present (es_array)) then
call simulation%write_event (es_array, passed, event_handle_out)
end if
end subroutine simulation_next_event
@ %def simulation_next_event
@ Cleanup after last event: compute and show summary information.
<<Simulations: simulation: TBP>>=
procedure :: after_last_event => simulation_after_last_event
<<Simulations: sub interfaces>>=
module subroutine simulation_after_last_event (simulation, begin_it, end_it)
class(simulation_t), intent(inout) :: simulation
integer, intent(in) :: begin_it, end_it
end subroutine simulation_after_last_event
<<Simulations: procedures>>=
module subroutine simulation_after_last_event (simulation, begin_it, end_it)
class(simulation_t), intent(inout) :: simulation
integer, intent(in) :: begin_it, end_it
call msg_message (" ... event sample complete.")
<<Simulations: simulation generate: extra finalize>>
if (simulation%unweighted) call simulation%show_efficiency ()
call simulation%counter%show_excess ()
call simulation%counter%show_dropped ()
call simulation%counter%show_mean_and_variance ()
end subroutine simulation_after_last_event
@ %def simulation_after_last_event
@
\subsubsection{MPI additions}
Below, we define code chunks that differ between the serial and MPI versions.
Extra logging for MPI only.
<<Simulations: simulation: TBP>>=
procedure :: activate_extra_logging => simulation_activate_extra_logging
<<Simulations: sub interfaces>>=
module subroutine simulation_activate_extra_logging (simulation)
class(simulation_t), intent(in) :: simulation
end subroutine simulation_activate_extra_logging
<<Simulations: procedures>>=
module subroutine simulation_activate_extra_logging (simulation)
class(simulation_t), intent(in) :: simulation
<<Simulations: activate extra logging>>
end subroutine simulation_activate_extra_logging
<<Simulations: activate extra logging>>=
<<MPI: Simulations: activate extra logging>>=
logical :: mpi_logging
integer :: rank, n_size
call mpi_get_comm_id (n_size, rank)
mpi_logging = &
(simulation%local%get_sval (var_str ("$integration_method")) == "vamp2" &
.and. n_size > 1) &
.or. simulation%local%get_lval (var_str ("?mpi_logging"))
call mpi_set_logging (mpi_logging)
@ %def simulation_activate_extra_logging
@
Extra subroutine to be called before the first event:
<<Simulations: simulation generate: extra init>>=
<<MPI: Simulations: simulation generate: extra init>>=
call simulation%init_event_loop_mpi (n_evt_requested, begin_it, end_it)
@
Extra subroutine to be called after the last event:
<<Simulations: simulation generate: extra finalize>>=
<<MPI: Simulations: simulation generate: extra finalize>>=
call simulation%final_event_loop_mpi (begin_it, end_it)
@
For MPI event generation, the event-loop interval (1\dots n) is split up
into intervals of [[n_workers]].
<<MPI: Simulations: simulation: TBP>>=
procedure, private :: init_event_loop_mpi => simulation_init_event_loop_mpi
<<MPI: Simulations: sub interfaces>>=
module subroutine simulation_init_event_loop_mpi &
(simulation, n_events, begin_it, end_it)
class(simulation_t), intent(inout) :: simulation
integer, intent(in) :: n_events
integer, intent(out) :: begin_it, end_it
end subroutine simulation_init_event_loop_mpi
<<MPI: Simulations: procedures>>=
module subroutine simulation_init_event_loop_mpi &
(simulation, n_events, begin_it, end_it)
class(simulation_t), intent(inout) :: simulation
integer, intent(in) :: n_events
integer, intent(out) :: begin_it, end_it
integer :: rank, n_workers
call MPI_COMM_SIZE (MPI_COMM_WORLD, n_workers)
if (n_workers < 2) then
begin_it = 1; end_it = n_events
return
end if
call MPI_COMM_RANK (MPI_COMM_WORLD, rank)
if (rank == 0) then
call compute_and_scatter_intervals (n_events, begin_it, end_it)
else
call retrieve_intervals (begin_it, end_it)
end if
!! Event index starts by 0 (before incrementing when the first event gets generated/read in).
!! Proof: event_index_offset in [0, N], start_it in [1, N].
simulation%event_index_offset = simulation%event_index_offset + (begin_it - 1)
call simulation%init_event_index ()
write (msg_buffer, "(A,I0,A,I0,A)") &
& "MPI: generate events [", begin_it, ":", end_it, "]"
call msg_message ()
contains
subroutine compute_and_scatter_intervals (n_events, begin_it, end_it)
integer, intent(in) :: n_events
integer, intent(out) :: begin_it, end_it
integer, dimension(:), allocatable :: all_begin_it, all_end_it
integer :: rank, n_workers, n_events_per_worker
call MPI_COMM_RANK (MPI_COMM_WORLD, rank)
call MPI_COMM_SIZE (MPI_COMM_WORLD, n_workers)
allocate (all_begin_it (n_workers), source = 1)
allocate (all_end_it (n_workers), source = n_events)
n_events_per_worker = floor (real (n_events, default) / n_workers)
all_begin_it = [(1 + rank * n_events_per_worker, rank = 0, n_workers - 1)]
all_end_it = [(rank * n_events_per_worker, rank = 1, n_workers)]
all_end_it(n_workers) = n_events
call MPI_SCATTER (all_begin_it, 1, MPI_INTEGER, begin_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD)
call MPI_SCATTER (all_end_it, 1, MPI_INTEGER, end_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD)
end subroutine compute_and_scatter_intervals
subroutine retrieve_intervals (begin_it, end_it)
integer, intent(out) :: begin_it, end_it
integer :: local_begin_it, local_end_it
call MPI_SCATTER (local_begin_it, 1, MPI_INTEGER, begin_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD)
call MPI_SCATTER (local_end_it, 1, MPI_INTEGER, end_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD)
end subroutine retrieve_intervals
end subroutine simulation_init_event_loop_mpi
@ %def simulation_init_event_loop_mpi
@
Synchronize, reduce and collect stuff after the event loop has completed.
<<MPI: Simulations: simulation: TBP>>=
procedure, private :: final_event_loop_mpi => simulation_final_event_loop_mpi
<<MPI: Simulations: sub interfaces>>=
module subroutine simulation_final_event_loop_mpi &
(simulation, begin_it, end_it)
class(simulation_t), intent(inout) :: simulation
integer, intent(in) :: begin_it, end_it
end subroutine simulation_final_event_loop_mpi
<<MPI: Simulations: procedures>>=
module subroutine simulation_final_event_loop_mpi &
(simulation, begin_it, end_it)
class(simulation_t), intent(inout) :: simulation
integer, intent(in) :: begin_it, end_it
integer :: n_workers, n_events_local, n_events_global
call MPI_Barrier (MPI_COMM_WORLD)
call MPI_COMM_SIZE (MPI_COMM_WORLD, n_workers)
if (n_workers < 2) return
n_events_local = end_it - begin_it + 1
call MPI_ALLREDUCE (n_events_local, n_events_global, 1, &
MPI_INTEGER, MPI_SUM,&
& MPI_COMM_WORLD)
write (msg_buffer, "(2(A,1X,I0))") &
"MPI: Number of generated events locally", n_events_local, &
" and in world", n_events_global
call msg_message ()
call simulation%counter%allreduce_record ()
end subroutine simulation_final_event_loop_mpi
@ %def simulation_final_event_loop_mpi
@
\subsubsection{Alternate environments}
Compute the event matrix element and weight for all alternative
environments, given the current event and selected process. We first
copy the particle set, then temporarily update the process core with
local parameters, recalculate everything, and restore the process
core.
The event weight is obtained by rescaling the original event weight with the
ratio of the new and old [[sqme]] values. (In particular, if the old
value was zero, the weight will stay zero.)
Note: this may turn out to be inefficient because we always replace
all parameters and recalculate everything, once for each event and
environment. However, a more fine-grained control requires more
code. In any case, while we may keep multiple process cores (which
stay constant for a simulation run), we still have to update the
external matrix element parameters event by event. The matrix element
``object'' is present only once.
<<Simulations: simulation: TBP>>=
procedure :: calculate_alt_entries => simulation_calculate_alt_entries
<<Simulations: sub interfaces>>=
module subroutine simulation_calculate_alt_entries (simulation)
class(simulation_t), intent(inout) :: simulation
end subroutine simulation_calculate_alt_entries
<<Simulations: procedures>>=
module subroutine simulation_calculate_alt_entries (simulation)
class(simulation_t), intent(inout) :: simulation
real(default) :: sqme_prc, weight_prc, factor
real(default), dimension(:), allocatable :: sqme_alt, weight_alt
integer :: n_alt, i, j
i = simulation%i_prc
n_alt = simulation%n_alt
if (n_alt == 0) return
allocate (sqme_alt (n_alt), weight_alt (n_alt))
associate (entry => simulation%entry(i))
do j = 1, n_alt
if (signal_is_pending ()) return
if (simulation%update_weight) then
factor = entry%get_kinematical_weight ()
else
sqme_prc = entry%get_sqme_prc ()
weight_prc = entry%get_weight_prc ()
if (sqme_prc /= 0) then
factor = weight_prc / sqme_prc
else
factor = 0
end if
end if
associate (alt_entry => simulation%alt_entry(i,j))
call alt_entry%update_process (saved=.false.)
call alt_entry%select &
(entry%get_i_mci (), entry%get_i_term (), entry%get_channel ())
call alt_entry%fill_particle_set (entry)
call alt_entry%recalculate &
(update_sqme = .true., &
recover_beams = simulation%recover_beams, &
weight_factor = factor)
if (signal_is_pending ()) return
call alt_entry%accept_sqme_prc ()
call alt_entry%update_normalization ()
call alt_entry%accept_weight_prc ()
call alt_entry%check ()
call alt_entry%set_index (simulation%get_event_index ())
call alt_entry%evaluate_expressions ()
if (signal_is_pending ()) return
sqme_alt(j) = alt_entry%get_sqme_ref ()
if (alt_entry%passed_selection ()) then
weight_alt(j) = alt_entry%get_weight_ref ()
end if
end associate
end do
call entry%update_process (saved=.false.)
call entry%set (sqme_alt = sqme_alt, weight_alt = weight_alt)
call entry%check ()
call entry%store_alt_values ()
end associate
end subroutine simulation_calculate_alt_entries
@ %def simulation_calculate_alt_entries
@
These routines take care of temporary parameter redefinitions that
we want to take effect while recalculating the matrix elements. We
extract the core(s) of the processes that we are simulating, apply the
changes, and make sure that the changes are actually used. This is
the duty of [[dispatch_core_update]]. When done, we restore the
original versions using [[dispatch_core_restore]].
<<Simulations: simulation: TBP>>=
procedure :: update_processes => simulation_update_processes
procedure :: restore_processes => simulation_restore_processes
<<Simulations: sub interfaces>>=
module subroutine simulation_update_processes (simulation, &
model, qcd, helicity_selection)
class(simulation_t), intent(inout) :: simulation
class(model_data_t), intent(in), optional, target :: model
type(qcd_t), intent(in), optional :: qcd
type(helicity_selection_t), intent(in), optional :: helicity_selection
end subroutine simulation_update_processes
module subroutine simulation_restore_processes (simulation)
class(simulation_t), intent(inout) :: simulation
end subroutine simulation_restore_processes
<<Simulations: procedures>>=
module subroutine simulation_update_processes (simulation, &
model, qcd, helicity_selection)
class(simulation_t), intent(inout) :: simulation
class(model_data_t), intent(in), optional, target :: model
type(qcd_t), intent(in), optional :: qcd
type(helicity_selection_t), intent(in), optional :: helicity_selection
integer :: i
do i = 1, simulation%n_prc
call simulation%entry(i)%update_process &
(model, qcd, helicity_selection)
end do
end subroutine simulation_update_processes
module subroutine simulation_restore_processes (simulation)
class(simulation_t), intent(inout) :: simulation
integer :: i
do i = 1, simulation%n_prc
call simulation%entry(i)%restore_process ()
end do
end subroutine simulation_restore_processes
@ %def simulation_update_processes
@ %def simulation_restore_processes
@
\subsubsection{Rescan-Events Loop}
Rescan an undefined number of events.
If [[update_event]] or [[update_sqme]] is set, we have to recalculate the
event, starting from the particle set. If the latter is set, this includes
the squared matrix element (i.e., the amplitude is evaluated). Otherwise,
only kinematics and observables derived from it are recovered.
If any of the update flags is set, we will come up with separate
[[sqme_prc]] and [[weight_prc]] values. (The latter is only distinct
if [[update_weight]] is set.) Otherwise, we accept the reference values.
<<Simulations: simulation: TBP>>=
procedure :: rescan => simulation_rescan
<<Simulations: sub interfaces>>=
module subroutine simulation_rescan (simulation, n, es_array, global)
class(simulation_t), intent(inout) :: simulation
integer, intent(in) :: n
type(event_stream_array_t), intent(inout) :: es_array
type(rt_data_t), intent(inout) :: global
end subroutine simulation_rescan
<<Simulations: procedures>>=
module subroutine simulation_rescan (simulation, n, es_array, global)
class(simulation_t), intent(inout) :: simulation
integer, intent(in) :: n
type(event_stream_array_t), intent(inout) :: es_array
type(rt_data_t), intent(inout) :: global
type(qcd_t) :: qcd
type(string_t) :: str1, str2, str3
logical :: complete, check_match
str1 = "Rescanning"
if (simulation%entry(1)%config%unweighted) then
str2 = "unweighted"
else
str2 = "weighted"
end if
simulation%n_evt_requested = n
call simulation%entry%set_n (n)
if (simulation%update_sqme .or. simulation%update_weight) then
call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
call simulation%update_processes &
(global%model, qcd, global%get_helicity_selection ())
str3 = "(process parameters updated) "
else
str3 = ""
end if
write (msg_buffer, "(A,1x,A,1x,A,A,A)") char (str1), char (str2), &
"events ", char (str3), "..."
call msg_message ()
call simulation%init_event_index ()
check_match = .not. global%var_list%get_lval (var_str ("?rescan_force"))
do
call simulation%increment_event_index ()
call simulation%read_event (es_array, .false., complete)
if (complete) exit
if (simulation%update_event &
.or. simulation%update_sqme &
.or. simulation%update_weight) then
call simulation%recalculate (check_match = check_match)
if (signal_is_pending ()) return
associate (entry => simulation%entry(simulation%i_prc))
call entry%update_normalization ()
if (simulation%update_event) then
call entry%evaluate_transforms ()
end if
call entry%check ()
call entry%evaluate_expressions ()
if (signal_is_pending ()) return
simulation%n_dropped = entry%get_n_dropped ()
simulation%weight = entry%get_weight_prc ()
call simulation%counter%record &
(simulation%weight, n_dropped=simulation%n_dropped, from_file=.true.)
call entry%record (simulation%i_mci, from_file=.true.)
end associate
else
associate (entry => simulation%entry(simulation%i_prc))
call entry%accept_sqme_ref ()
call entry%accept_weight_ref ()
call entry%check ()
call entry%evaluate_expressions ()
if (signal_is_pending ()) return
simulation%n_dropped = entry%get_n_dropped ()
simulation%weight = entry%get_weight_ref ()
call simulation%counter%record &
(simulation%weight, n_dropped=simulation%n_dropped, from_file=.true.)
call entry%record (simulation%i_mci, from_file=.true.)
end associate
end if
call simulation%calculate_alt_entries ()
if (signal_is_pending ()) return
call simulation%write_event (es_array)
end do
call simulation%counter%show_dropped ()
if (simulation%update_sqme .or. simulation%update_weight) then
call simulation%restore_processes ()
end if
end subroutine simulation_rescan
@ %def simulation_rescan
@
\subsubsection{Event index}
Here we handle the event index that is kept in the simulation record. The
event index is valid for the current sample. When generating or reading
events, we initialize the index with the offset that the user provides (if any)
and increment it for each event that is generated or read from file. The event
index is stored in the event-entry that is current for the event. If an
event on file comes with its own index, that index overwrites the predefined
one and also resets the index within the simulation record.
The event index is not connected to the [[counter]] object. The counter is
supposed to collect statistical information. The event index is a user-level
object that is visible in event records and analysis expressions.
<<Simulations: simulation: TBP>>=
procedure :: init_event_index => simulation_init_event_index
procedure :: increment_event_index => simulation_increment_event_index
procedure :: set_event_index => simulation_set_event_index
procedure :: get_event_index => simulation_get_event_index
<<Simulations: sub interfaces>>=
module subroutine simulation_init_event_index (simulation)
class(simulation_t), intent(inout) :: simulation
end subroutine simulation_init_event_index
module subroutine simulation_increment_event_index (simulation)
class(simulation_t), intent(inout) :: simulation
end subroutine simulation_increment_event_index
module subroutine simulation_set_event_index (simulation, i)
class(simulation_t), intent(inout) :: simulation
integer, intent(in) :: i
end subroutine simulation_set_event_index
module function simulation_get_event_index (simulation) result (i)
class(simulation_t), intent(in) :: simulation
integer :: i
end function simulation_get_event_index
<<Simulations: procedures>>=
module subroutine simulation_init_event_index (simulation)
class(simulation_t), intent(inout) :: simulation
call simulation%set_event_index (simulation%event_index_offset)
end subroutine simulation_init_event_index
module subroutine simulation_increment_event_index (simulation)
class(simulation_t), intent(inout) :: simulation
if (simulation%event_index_set) then
simulation%event_index = simulation%event_index + 1
end if
end subroutine simulation_increment_event_index
module subroutine simulation_set_event_index (simulation, i)
class(simulation_t), intent(inout) :: simulation
integer, intent(in) :: i
simulation%event_index = i
simulation%event_index_set = .true.
end subroutine simulation_set_event_index
module function simulation_get_event_index (simulation) result (i)
class(simulation_t), intent(in) :: simulation
integer :: i
if (simulation%event_index_set) then
i = simulation%event_index
else
i = 0
end if
end function simulation_get_event_index
@ %def simulation_init_event_index
@ %def simulation_increment_event_index
@ %def simulation_set_event_index
@ %def simulation_get_event_index
@
\subsection{Direct event access}
If we want to retrieve event information, we should expose the currently
selected event [[entry]] within the simulation object. We recall that this is
an extension of the (generic) [[event]] type. Assuming that we will restrict
this to read access, we return a pointer.
<<Simulations: simulation: TBP>>=
procedure :: get_process_index => simulation_get_process_index
procedure :: get_event_ptr => simulation_get_event_ptr
<<Simulations: sub interfaces>>=
module function simulation_get_process_index (simulation) result (i_prc)
class(simulation_t), intent(in), target :: simulation
integer :: i_prc
end function simulation_get_process_index
module function simulation_get_event_ptr (simulation) result (event)
class(simulation_t), intent(in), target :: simulation
class(event_t), pointer :: event
end function simulation_get_event_ptr
<<Simulations: procedures>>=
module function simulation_get_process_index (simulation) result (i_prc)
class(simulation_t), intent(in), target :: simulation
integer :: i_prc
i_prc = simulation%i_prc
end function simulation_get_process_index
module function simulation_get_event_ptr (simulation) result (event)
class(simulation_t), intent(in), target :: simulation
class(event_t), pointer :: event
event => simulation%entry(simulation%i_prc)
end function simulation_get_event_ptr
@ %def simulation_get_process_index
@ %def simulation_get_event_ptr
@
\subsection{Event Stream I/O}
Write an event to a generic [[eio]] event stream. The process index
must be selected, or the current index must be available.
<<Simulations: simulation: TBP>>=
generic :: write_event => write_event_eio
procedure :: write_event_eio => simulation_write_event_eio
<<Simulations: sub interfaces>>=
module subroutine simulation_write_event_eio (object, eio, i_prc)
class(simulation_t), intent(in) :: object
class(eio_t), intent(inout) :: eio
integer, intent(in), optional :: i_prc
end subroutine simulation_write_event_eio
<<Simulations: procedures>>=
module subroutine simulation_write_event_eio (object, eio, i_prc)
class(simulation_t), intent(in) :: object
class(eio_t), intent(inout) :: eio
integer, intent(in), optional :: i_prc
logical :: increased
integer :: current
if (present (i_prc)) then
current = i_prc
else
current = object%i_prc
end if
if (current > 0) then
if (object%split_n_evt > 0 .and. object%counter%total > 1) then
if (mod (object%counter%total, object%split_n_evt) == 1) then
call eio%split_out ()
end if
else if (object%split_n_kbytes > 0) then
call eio%update_split_count (increased)
if (increased) call eio%split_out ()
end if
call eio%output (object%entry(current)%event_t, current, pacify = object%pacify)
else
call msg_fatal ("Simulation: write event: no process selected")
end if
end subroutine simulation_write_event_eio
@ %def simulation_write_event
@
Read an event from a generic [[eio]] event stream. The event stream element
must specify the process within the sample ([[i_prc]]), the MC group for this
process ([[i_mci]]), the selected term ([[i_term]]), the selected MC
integration [[channel]], and the particle set of the event.
We may encounter EOF, which we indicate by storing 0 for the process index
[[i_prc]]. An I/O error will be reported, and we also abort reading.
<<Simulations: simulation: TBP>>=
generic :: read_event => read_event_eio
procedure :: read_event_eio => simulation_read_event_eio
<<Simulations: sub interfaces>>=
module subroutine simulation_read_event_eio (object, eio)
class(simulation_t), intent(inout) :: object
class(eio_t), intent(inout) :: eio
end subroutine simulation_read_event_eio
<<Simulations: procedures>>=
module subroutine simulation_read_event_eio (object, eio)
class(simulation_t), intent(inout) :: object
class(eio_t), intent(inout) :: eio
integer :: iostat, current
call eio%input_i_prc (current, iostat)
select case (iostat)
case (0)
object%i_prc = current
call eio%input_event (object%entry(current)%event_t, iostat)
end select
select case (iostat)
case (:-1)
object%i_prc = 0
object%i_mci = 0
case (1:)
call msg_error ("Reading events: I/O error, aborting read")
object%i_prc = 0
object%i_mci = 0
case default
object%i_mci = object%entry(current)%get_i_mci ()
end select
end subroutine simulation_read_event_eio
@ %def simulation_read_event
@
\subsection{Event Stream Array}
Write an event using an array of event I/O streams.
The process index must be selected, or the current index must be
available.
<<Simulations: simulation: TBP>>=
generic :: write_event => write_event_es_array
procedure :: write_event_es_array => simulation_write_event_es_array
<<Simulations: sub interfaces>>=
module subroutine simulation_write_event_es_array &
(object, es_array, passed, event_handle)
class(simulation_t), intent(in), target :: object
class(event_stream_array_t), intent(inout) :: es_array
logical, intent(in), optional :: passed
class(event_handle_t), intent(inout), optional :: event_handle
end subroutine simulation_write_event_es_array
<<Simulations: procedures>>=
module subroutine simulation_write_event_es_array &
(object, es_array, passed, event_handle)
class(simulation_t), intent(in), target :: object
class(event_stream_array_t), intent(inout) :: es_array
logical, intent(in), optional :: passed
class(event_handle_t), intent(inout), optional :: event_handle
integer :: i_prc, event_index
integer :: i
type(entry_t), pointer :: current_entry
i_prc = object%i_prc
if (i_prc > 0) then
event_index = object%counter%total
current_entry => object%entry(i_prc)%get_first ()
do i = 1, current_entry%count_nlo_entries ()
if (i > 1) current_entry => current_entry%get_next ()
call es_array%output (current_entry%event_t, i_prc, &
event_index, &
passed = passed, &
pacify = object%pacify, &
event_handle = event_handle)
end do
else
call msg_fatal ("Simulation: write event: no process selected")
end if
end subroutine simulation_write_event_es_array
@ %def simulation_write_event
@ Read an event using an array of event I/O streams. Reading is
successful if there is an input stream within the array, and if a
valid event can be read from that stream. If there is a stream, but
EOF is passed when reading the first item, we switch the channel to
output and return failure but no error message, such that new events
can be appended to that stream.
<<Simulations: simulation: TBP>>=
generic :: read_event => read_event_es_array
procedure :: read_event_es_array => simulation_read_event_es_array
<<Simulations: sub interfaces>>=
module subroutine simulation_read_event_es_array &
(object, es_array, enable_switch, fail, event_handle)
class(simulation_t), intent(inout), target :: object
class(event_stream_array_t), intent(inout), target :: es_array
logical, intent(in) :: enable_switch
logical, intent(out) :: fail
class(event_handle_t), intent(inout), optional :: event_handle
end subroutine simulation_read_event_es_array
<<Simulations: procedures>>=
module subroutine simulation_read_event_es_array &
(object, es_array, enable_switch, fail, event_handle)
class(simulation_t), intent(inout), target :: object
class(event_stream_array_t), intent(inout), target :: es_array
logical, intent(in) :: enable_switch
logical, intent(out) :: fail
class(event_handle_t), intent(inout), optional :: event_handle
integer :: iostat, i_prc
type(entry_t), pointer :: current_entry => null ()
integer :: i
if (es_array%has_input ()) then
fail = .false.
call es_array%input_i_prc (i_prc, iostat)
select case (iostat)
case (0)
object%i_prc = i_prc
current_entry => object%entry(i_prc)
do i = 1, current_entry%count_nlo_entries ()
if (i > 1) then
call es_array%skip_eio_entry (iostat)
current_entry => current_entry%get_next ()
end if
call current_entry%set_index (object%get_event_index ())
call es_array%input_event &
(current_entry%event_t, iostat, event_handle)
end do
case (:-1)
write (msg_buffer, "(A,1x,I0,1x,A)") &
"... event file terminates after", &
object%counter%read, "events."
call msg_message ()
if (enable_switch) then
call es_array%switch_inout ()
write (msg_buffer, "(A,1x,I0,1x,A)") &
"Generating remaining ", &
object%n_evt_requested - object%counter%read, "events ..."
call msg_message ()
end if
fail = .true.
return
end select
select case (iostat)
case (0)
object%i_mci = object%entry(i_prc)%get_i_mci ()
case default
write (msg_buffer, "(A,1x,I0,1x,A)") &
"Reading events: I/O error, aborting read after", &
object%counter%read, "events."
call msg_error ()
object%i_prc = 0
object%i_mci = 0
fail = .true.
end select
else
fail = .true.
end if
end subroutine simulation_read_event_es_array
@ %def simulation_read_event
@
\subsection{Recover event}
Recalculate the process instance contents, given an event with known particle
set. The indices for MC, term, and channel must be already set. The
[[recalculate]] method of the selected entry will import the result
into [[sqme_prc]] and [[weight_prc]].
If [[recover_phs]] is set (and false), do not attempt any phase-space
calculation. Useful if we need only matrix elements (esp. testing); this flag
is not stored in the simulation record.
<<Simulations: simulation: TBP>>=
procedure :: recalculate => simulation_recalculate
<<Simulations: sub interfaces>>=
module subroutine simulation_recalculate &
(simulation, recover_phs, check_match)
class(simulation_t), intent(inout) :: simulation
logical, intent(in), optional :: recover_phs
logical, intent(in), optional :: check_match
end subroutine simulation_recalculate
<<Simulations: procedures>>=
module subroutine simulation_recalculate &
(simulation, recover_phs, check_match)
class(simulation_t), intent(inout) :: simulation
logical, intent(in), optional :: recover_phs
logical, intent(in), optional :: check_match
integer :: i_prc, i_comp, i_term, k
integer :: i_mci, i_mci0, i_mci1
integer, dimension(:), allocatable :: i_terms
logical :: success
i_prc = simulation%i_prc
associate (entry => simulation%entry(i_prc))
if (entry%selected_i_mci /= 0) then
i_mci0 = entry%selected_i_mci
i_mci1 = i_mci0
else
i_mci0 = 1
i_mci1 = entry%process%get_n_mci ()
end if
SCAN_COMP: do i_mci = i_mci0, i_mci1
i_comp = entry%process%get_master_component (i_mci)
call entry%process%reset_selected_cores ()
call entry%process%select_components ([i_comp])
i_terms = entry%process%get_component_i_terms (i_comp)
SCAN_TERM: do k = 1, size (i_terms)
i_term = i_terms(k)
call entry%select (i_mci, i_term, entry%selected_channel)
if (entry%selected_i_term /= 0 &
.and. entry%selected_i_term /= i_term) cycle SCAN_TERM
call entry%select (i_mci, i_term, entry%selected_channel)
if (simulation%update_weight) then
call entry%recalculate &
(update_sqme = simulation%update_sqme, &
recover_beams = simulation%recover_beams, &
recover_phs = recover_phs, &
weight_factor = entry%get_kinematical_weight (), &
check_match = check_match, &
success = success)
else
call entry%recalculate &
(update_sqme = simulation%update_sqme, &
recover_beams = simulation%recover_beams, &
recover_phs = recover_phs, &
check_match = check_match, &
success = success)
end if
if (success) exit SCAN_COMP
end do SCAN_TERM
deallocate (i_terms)
end do SCAN_COMP
if (.not. success) then
call entry%write ()
call msg_fatal ("Simulation/recalculate: &
&event could not be matched to the specified process")
end if
end associate
end subroutine simulation_recalculate
@ %def simulation_recalculate
@
\subsection{Extract contents of the simulation object}
Return the MD5 sum that summarizes configuration and integration
(but not the event file). Used for initializing the event streams.
<<Simulations: simulation: TBP>>=
procedure :: get_md5sum_prc => simulation_get_md5sum_prc
procedure :: get_md5sum_cfg => simulation_get_md5sum_cfg
procedure :: get_md5sum_alt => simulation_get_md5sum_alt
<<Simulations: sub interfaces>>=
module function simulation_get_md5sum_prc (simulation) result (md5sum)
class(simulation_t), intent(in) :: simulation
character(32) :: md5sum
end function simulation_get_md5sum_prc
module function simulation_get_md5sum_cfg (simulation) result (md5sum)
class(simulation_t), intent(in) :: simulation
character(32) :: md5sum
end function simulation_get_md5sum_cfg
module function simulation_get_md5sum_alt (simulation, i) result (md5sum)
class(simulation_t), intent(in) :: simulation
integer, intent(in) :: i
character(32) :: md5sum
end function simulation_get_md5sum_alt
<<Simulations: procedures>>=
module function simulation_get_md5sum_prc (simulation) result (md5sum)
class(simulation_t), intent(in) :: simulation
character(32) :: md5sum
md5sum = simulation%md5sum_prc
end function simulation_get_md5sum_prc
module function simulation_get_md5sum_cfg (simulation) result (md5sum)
class(simulation_t), intent(in) :: simulation
character(32) :: md5sum
md5sum = simulation%md5sum_cfg
end function simulation_get_md5sum_cfg
module function simulation_get_md5sum_alt (simulation, i) result (md5sum)
class(simulation_t), intent(in) :: simulation
integer, intent(in) :: i
character(32) :: md5sum
md5sum = simulation%md5sum_alt(i)
end function simulation_get_md5sum_alt
@ %def simulation_get_md5sum_prc
@ %def simulation_get_md5sum_cfg
@
Return data that may be useful for writing event files.
Usually we can refer to a previously integrated process, for which we
can fetch a process pointer. Occasionally, we do not have this because
we are just rescanning an externally generated file without
calculation. For that situation, we generate our local beam data object
using the current enviroment, or, in simple cases, just fetch the
necessary data from the process definition and environment.
<<Simulations: simulation: TBP>>=
procedure :: get_data => simulation_get_data
<<Simulations: sub interfaces>>=
module function simulation_get_data (simulation, alt) result (sdata)
class(simulation_t), intent(in) :: simulation
logical, intent(in), optional :: alt
type(event_sample_data_t) :: sdata
end function simulation_get_data
<<Simulations: procedures>>=
module function simulation_get_data (simulation, alt) result (sdata)
class(simulation_t), intent(in) :: simulation
logical, intent(in), optional :: alt
type(event_sample_data_t) :: sdata
type(process_t), pointer :: process
type(beam_data_t), pointer :: beam_data
type(beam_structure_t), pointer :: beam_structure
type(flavor_t), dimension(:), allocatable :: flv
integer :: n, i
logical :: enable_alt, construct_beam_data
real(default) :: sqrts
class(model_data_t), pointer :: model
logical :: decay_rest_frame
type(string_t) :: process_id
enable_alt = .true.; if (present (alt)) enable_alt = alt
if (debug_on) call msg_debug (D_CORE, "simulation_get_data")
if (debug_on) call msg_debug (D_CORE, "alternative setup", enable_alt)
if (enable_alt) then
call sdata%init (simulation%n_prc, simulation%n_alt)
do i = 1, simulation%n_alt
sdata%md5sum_alt(i) = simulation%get_md5sum_alt (i)
end do
else
call sdata%init (simulation%n_prc)
end if
sdata%unweighted = simulation%unweighted
sdata%negative_weights = simulation%negative_weights
sdata%norm_mode = simulation%norm_mode
process => simulation%entry(1)%get_process_ptr ()
if (associated (process)) then
beam_data => process%get_beam_data_ptr ()
construct_beam_data = .false.
else
n = simulation%entry(1)%n_in
sqrts = simulation%local%get_sqrts ()
beam_structure => simulation%local%beam_structure
call beam_structure%check_against_n_in (n, construct_beam_data)
if (construct_beam_data) then
allocate (beam_data)
model => simulation%local%model
decay_rest_frame = &
simulation%local%get_lval (var_str ("?decay_rest_frame"))
call beam_data%init_structure (beam_structure, &
sqrts, model, decay_rest_frame)
else
beam_data => null ()
end if
end if
if (associated (beam_data)) then
n = beam_data%get_n_in ()
sdata%n_beam = n
allocate (flv (n))
flv = beam_data%get_flavor ()
sdata%pdg_beam(:n) = flv%get_pdg ()
sdata%energy_beam(:n) = beam_data%get_energy ()
if (construct_beam_data) deallocate (beam_data)
else
n = simulation%entry(1)%n_in
sdata%n_beam = n
process_id = simulation%entry(1)%process_id
call simulation%local%prclib%get_pdg_in_1 &
(process_id, sdata%pdg_beam(:n))
sdata%energy_beam(:n) = sqrts / n
end if
do i = 1, simulation%n_prc
if (.not. simulation%entry(i)%valid) cycle
process => simulation%entry(i)%get_process_ptr ()
if (associated (process)) then
sdata%proc_num_id(i) = process%get_num_id ()
else
process_id = simulation%entry(i)%process_id
sdata%proc_num_id(i) = simulation%local%prclib%get_num_id (process_id)
end if
if (sdata%proc_num_id(i) == 0) sdata%proc_num_id(i) = i
if (simulation%entry(i)%has_integral) then
sdata%cross_section(i) = simulation%entry(i)%integral
sdata%error(i) = simulation%entry(i)%error
end if
end do
sdata%total_cross_section = sum (sdata%cross_section)
sdata%md5sum_prc = simulation%get_md5sum_prc ()
sdata%md5sum_cfg = simulation%get_md5sum_cfg ()
if (simulation%split_n_evt > 0 .or. simulation%split_n_kbytes > 0) then
sdata%split_n_evt = simulation%split_n_evt
sdata%split_n_kbytes = simulation%split_n_kbytes
sdata%split_index = simulation%split_index
end if
end function simulation_get_data
@ %def simulation_get_data
@ Return a default name for the current event sample. This is the
process ID of the first process.
<<Simulations: simulation: TBP>>=
procedure :: get_default_sample_name => simulation_get_default_sample_name
<<Simulations: sub interfaces>>=
module function simulation_get_default_sample_name &
(simulation) result (sample)
class(simulation_t), intent(in) :: simulation
type(string_t) :: sample
end function simulation_get_default_sample_name
<<Simulations: procedures>>=
module function simulation_get_default_sample_name &
(simulation) result (sample)
class(simulation_t), intent(in) :: simulation
type(string_t) :: sample
type(process_t), pointer :: process
sample = "whizard"
if (simulation%n_prc > 0) then
process => simulation%entry(1)%get_process_ptr ()
if (associated (process)) then
sample = process%get_id ()
end if
end if
end function simulation_get_default_sample_name
@ %def simulation_get_default_sample_name
@
<<Simulations: simulation: TBP>>=
procedure :: is_valid => simulation_is_valid
<<Simulations: sub interfaces>>=
module function simulation_is_valid (simulation) result (valid)
class(simulation_t), intent(inout) :: simulation
logical :: valid
end function simulation_is_valid
<<Simulations: procedures>>=
module function simulation_is_valid (simulation) result (valid)
class(simulation_t), intent(inout) :: simulation
logical :: valid
valid = simulation%valid
end function simulation_is_valid
@ %def simulation_is_valid
@
Return the hard-interaction particle set for event entry [[i_prc]].
<<Simulations: simulation: TBP>>=
procedure :: get_hard_particle_set => simulation_get_hard_particle_set
<<Simulations: sub interfaces>>=
module function simulation_get_hard_particle_set &
(simulation, i_prc) result (pset)
class(simulation_t), intent(in) :: simulation
integer, intent(in) :: i_prc
type(particle_set_t) :: pset
end function simulation_get_hard_particle_set
<<Simulations: procedures>>=
module function simulation_get_hard_particle_set &
(simulation, i_prc) result (pset)
class(simulation_t), intent(in) :: simulation
integer, intent(in) :: i_prc
type(particle_set_t) :: pset
call simulation%entry(i_prc)%get_hard_particle_set (pset)
end function simulation_get_hard_particle_set
@ %def simulation_get_hard_particle_set
@
\subsection{Auxiliary}
Call pacify: eliminate numerical noise.
<<Simulations: public>>=
public :: pacify
<<Simulations: interfaces>>=
interface pacify
module procedure pacify_simulation
end interface
<<Simulations: sub interfaces>>=
module subroutine pacify_simulation (simulation)
class(simulation_t), intent(inout) :: simulation
end subroutine pacify_simulation
<<Simulations: procedures>>=
module subroutine pacify_simulation (simulation)
class(simulation_t), intent(inout) :: simulation
integer :: i, j
i = simulation%i_prc
if (i > 0) then
call pacify (simulation%entry(i))
do j = 1, simulation%n_alt
call pacify (simulation%alt_entry(i,j))
end do
end if
end subroutine pacify_simulation
@ %def pacify_simulation
@ Manually evaluate expressions for the currently selected process.
This is used only in the unit tests.
<<Simulations: simulation: TBP>>=
procedure :: evaluate_expressions => simulation_evaluate_expressions
<<Simulations: sub interfaces>>=
module subroutine simulation_evaluate_expressions (simulation)
class(simulation_t), intent(inout) :: simulation
end subroutine simulation_evaluate_expressions
<<Simulations: procedures>>=
module subroutine simulation_evaluate_expressions (simulation)
class(simulation_t), intent(inout) :: simulation
call simulation%entry(simulation%i_prc)%evaluate_expressions ()
end subroutine simulation_evaluate_expressions
@ %def simulation_evaluate_expressions
@ Manually evaluate event transforms for the currently selected
process. This is used only in the unit tests.
<<Simulations: simulation: TBP>>=
procedure :: evaluate_transforms => simulation_evaluate_transforms
<<Simulations: sub interfaces>>=
module subroutine simulation_evaluate_transforms (simulation)
class(simulation_t), intent(inout) :: simulation
- end subroutine simulation_evaluate_transforms
+ end subroutine simulation_evaluate_transforms
<<Simulations: procedures>>=
module subroutine simulation_evaluate_transforms (simulation)
class(simulation_t), intent(inout) :: simulation
associate (entry => simulation%entry(simulation%i_prc))
call entry%evaluate_transforms ()
end associate
end subroutine simulation_evaluate_transforms
@ %def simulation_evaluate_transforms
@
\subsection{Unit tests}
Test module, followed by the stand-alone unit-test procedures.
<<[[simulations_ut.f90]]>>=
<<File header>>
module simulations_ut
use unit_tests
use simulations_uti
<<Standard module head>>
<<Simulations: public test>>
contains
<<Simulations: test driver>>
end module simulations_ut
@ %def simulations_ut
@
<<[[simulations_uti.f90]]>>=
<<File header>>
module simulations_uti
<<Use kinds>>
use kinds, only: i64
<<Use strings>>
use io_units
use format_defs, only: FMT_10, FMT_12
use ifiles
use lexers
use parser
use lorentz
use flavors
use interactions, only: reset_interaction_counter
use process_libraries, only: process_library_t
use prclib_stacks
use phs_forests
use event_base, only: generic_event_t
use event_base, only: event_callback_t
use particles, only: particle_set_t
use eio_data
use eio_base
use eio_direct, only: eio_direct_t
use eio_raw
use eio_ascii
use eio_dump
use eio_callback
use eval_trees
use model_data, only: model_data_t
use models
use rt_data
use event_streams
use decays_ut, only: prepare_testbed
use process, only: process_t
use process_stacks, only: process_entry_t
use process_configurations_ut, only: prepare_test_library
use compilations, only: compile_library
use integrations, only: integrate_process
use simulations
use restricted_subprocesses_uti, only: prepare_resonance_test_library
<<Standard module head>>
<<Simulations: test declarations>>
<<Simulations: test auxiliary types>>
contains
<<Simulations: tests>>
<<Simulations: test auxiliary>>
end module simulations_uti
@ %def simulations_uti
@ API: driver for the unit tests below.
<<Simulations: public test>>=
public :: simulations_test
<<Simulations: test driver>>=
subroutine simulations_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Simulations: execute tests>>
end subroutine simulations_test
@ %def simulations_test
@
\subsubsection{Initialization}
Initialize a [[simulation_t]] object, including the embedded event records.
<<Simulations: execute tests>>=
call test (simulations_1, "simulations_1", &
"initialization", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_1
<<Simulations: tests>>=
subroutine simulations_1 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname1, procname2
type(rt_data_t), target :: global
type(simulation_t), target :: simulation
write (u, "(A)") "* Test output: simulations_1"
write (u, "(A)") "* Purpose: initialize simulation"
write (u, "(A)")
write (u, "(A)") "* Initialize processes"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
libname = "simulation_1a"
procname1 = "simulation_1p"
call prepare_test_library (global, libname, 1, [procname1])
call compile_library (libname, global)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([1], [1000])
call global%set_string (var_str ("$run_id"), &
var_str ("simulations1"), is_known = .true.)
call integrate_process (procname1, global, local_stack=.true.)
procname2 = "sim_extra"
call prepare_test_library (global, libname, 1, [procname2])
call compile_library (libname, global)
call global%set_string (var_str ("$run_id"), &
var_str ("simulations2"), is_known = .true.)
write (u, "(A)") "* Initialize event generation"
write (u, "(A)")
call global%set_string (var_str ("$sample"), &
var_str ("sim1"), is_known = .true.)
call integrate_process (procname2, global, local_stack=.true.)
call simulation%init ([procname1, procname2], .false., .true., global)
call simulation%init_process_selector ()
call simulation%write (u)
write (u, "(A)")
write (u, "(A)") "* Write the event record for the first process"
write (u, "(A)")
call simulation%write_event (u, i_prc = 1)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call simulation%final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_1"
end subroutine simulations_1
@ %def simulations_1
@
\subsubsection{Weighted events}
Generate events for a single process.
<<Simulations: execute tests>>=
call test (simulations_2, "simulations_2", &
"weighted events", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_2
<<Simulations: tests>>=
subroutine simulations_2 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname1
type(rt_data_t), target :: global
type(simulation_t), target :: simulation
type(event_sample_data_t) :: data
write (u, "(A)") "* Test output: simulations_2"
write (u, "(A)") "* Purpose: generate events for a single process"
write (u, "(A)")
write (u, "(A)") "* Initialize processes"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
libname = "simulation_2a"
procname1 = "simulation_2p"
call prepare_test_library (global, libname, 1, [procname1])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([1], [1000])
call global%set_string (var_str ("$run_id"), &
var_str ("simulations1"), is_known = .true.)
call integrate_process (procname1, global, local_stack=.true.)
write (u, "(A)") "* Initialize event generation"
write (u, "(A)")
call global%set_log (var_str ("?unweighted"), &
.false., is_known = .true.)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
data = simulation%get_data ()
call data%write (u)
write (u, "(A)")
write (u, "(A)") "* Generate three events"
write (u, "(A)")
call simulation%set_n_events_requested (3)
call simulation%generate ()
call simulation%write (u)
write (u, "(A)")
write (u, "(A)") "* Write the event record for the last event"
write (u, "(A)")
call simulation%write_event (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call simulation%final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_2"
end subroutine simulations_2
@ %def simulations_2
@
\subsubsection{Unweighted events}
Generate events for a single process.
<<Simulations: execute tests>>=
call test (simulations_3, "simulations_3", &
"unweighted events", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_3
<<Simulations: tests>>=
subroutine simulations_3 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname1
type(rt_data_t), target :: global
type(simulation_t), target :: simulation
type(event_sample_data_t) :: data
write (u, "(A)") "* Test output: simulations_3"
write (u, "(A)") "* Purpose: generate unweighted events &
&for a single process"
write (u, "(A)")
write (u, "(A)") "* Initialize processes"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
libname = "simulation_3a"
procname1 = "simulation_3p"
call prepare_test_library (global, libname, 1, [procname1])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([1], [1000])
call global%set_string (var_str ("$run_id"), &
var_str ("simulations1"), is_known = .true.)
call integrate_process (procname1, global, local_stack=.true.)
write (u, "(A)") "* Initialize event generation"
write (u, "(A)")
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
data = simulation%get_data ()
call data%write (u)
write (u, "(A)")
write (u, "(A)") "* Generate three events"
write (u, "(A)")
call simulation%set_n_events_requested (3)
call simulation%generate ()
call simulation%write (u)
write (u, "(A)")
write (u, "(A)") "* Write the event record for the last event"
write (u, "(A)")
call simulation%write_event (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call simulation%final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_3"
end subroutine simulations_3
@ %def simulations_3
@
\subsubsection{Simulating process with structure functions}
Generate events for a single process.
<<Simulations: execute tests>>=
call test (simulations_4, "simulations_4", &
"process with structure functions", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_4
<<Simulations: tests>>=
subroutine simulations_4 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname1
type(rt_data_t), target :: global
type(flavor_t) :: flv
type(string_t) :: name
type(simulation_t), target :: simulation
type(event_sample_data_t) :: data
write (u, "(A)") "* Test output: simulations_4"
write (u, "(A)") "* Purpose: generate events for a single process &
&with structure functions"
write (u, "(A)")
write (u, "(A)") "* Initialize processes"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_phs_forest_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
libname = "simulation_4a"
procname1 = "simulation_4p"
call prepare_test_library (global, libname, 1, [procname1])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("wood"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("vamp"), is_known = .true.)
call global%set_log (var_str ("?use_vamp_equivalences"),&
.true., is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%model_set_real (var_str ("ms"), &
0._default)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call reset_interaction_counter ()
call flv%init (25, global%model)
name = flv%get_name ()
call global%beam_structure%init_sf ([name, name], [1])
call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))
write (u, "(A)") "* Integrate"
write (u, "(A)")
call global%it_list%init ([1], [1000])
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call integrate_process (procname1, global, local_stack=.true.)
write (u, "(A)") "* Initialize event generation"
write (u, "(A)")
call global%set_log (var_str ("?unweighted"), &
.false., is_known = .true.)
call global%set_string (var_str ("$sample"), &
var_str ("simulations4"), is_known = .true.)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
data = simulation%get_data ()
call data%write (u)
write (u, "(A)")
write (u, "(A)") "* Generate three events"
write (u, "(A)")
call simulation%set_n_events_requested (3)
call simulation%generate ()
call simulation%write (u)
write (u, "(A)")
write (u, "(A)") "* Write the event record for the last event"
write (u, "(A)")
call simulation%write_event (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call simulation%final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_4"
end subroutine simulations_4
@ %def simulations_4
@
\subsubsection{Event I/O}
Generate event for a test process, write to file and reread.
<<Simulations: execute tests>>=
call test (simulations_5, "simulations_5", &
"raw event I/O", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_5
<<Simulations: tests>>=
subroutine simulations_5 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname1, sample
type(rt_data_t), target :: global
class(eio_t), allocatable :: eio
type(simulation_t), allocatable, target :: simulation
write (u, "(A)") "* Test output: simulations_5"
write (u, "(A)") "* Purpose: generate events for a single process"
write (u, "(A)") "* write to file and reread"
write (u, "(A)")
write (u, "(A)") "* Initialize processes"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
libname = "simulation_5a"
procname1 = "simulation_5p"
call prepare_test_library (global, libname, 1, [procname1])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([1], [1000])
call global%set_string (var_str ("$run_id"), &
var_str ("simulations5"), is_known = .true.)
call integrate_process (procname1, global, local_stack=.true.)
write (u, "(A)") "* Initialize event generation"
write (u, "(A)")
call global%set_log (var_str ("?unweighted"), &
.false., is_known = .true.)
sample = "simulations5"
call global%set_string (var_str ("$sample"), &
sample, is_known = .true.)
allocate (simulation)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
write (u, "(A)") "* Initialize raw event file"
write (u, "(A)")
allocate (eio_raw_t :: eio)
call eio%init_out (sample)
write (u, "(A)") "* Generate an event"
write (u, "(A)")
call simulation%set_n_events_requested (1)
call simulation%generate ()
call simulation%write_event (u)
call simulation%write_event (eio)
call eio%final ()
deallocate (eio)
call simulation%final ()
deallocate (simulation)
write (u, "(A)")
write (u, "(A)") "* Re-read the event from file"
write (u, "(A)")
call global%set_log (var_str ("?update_sqme"), &
.true., is_known = .true.)
call global%set_log (var_str ("?update_weight"), &
.true., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
allocate (simulation)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
allocate (eio_raw_t :: eio)
call eio%init_in (sample)
call simulation%read_event (eio)
call simulation%write_event (u)
write (u, "(A)")
write (u, "(A)") "* Recalculate process instance"
write (u, "(A)")
call simulation%recalculate ()
call simulation%evaluate_expressions ()
call simulation%write_event (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio%final ()
call simulation%final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_5"
end subroutine simulations_5
@ %def simulations_5
@
\subsubsection{Event I/O}
Generate event for a real process with structure functions, write to file and
reread.
<<Simulations: execute tests>>=
call test (simulations_6, "simulations_6", &
"raw event I/O with structure functions", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_6
<<Simulations: tests>>=
subroutine simulations_6 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname1, sample
type(rt_data_t), target :: global
class(eio_t), allocatable :: eio
type(simulation_t), allocatable, target :: simulation
type(flavor_t) :: flv
type(string_t) :: name
write (u, "(A)") "* Test output: simulations_6"
write (u, "(A)") "* Purpose: generate events for a single process"
write (u, "(A)") "* write to file and reread"
write (u, "(A)")
write (u, "(A)") "* Initialize process and integrate"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
libname = "simulation_6"
procname1 = "simulation_6p"
call prepare_test_library (global, libname, 1, [procname1])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("wood"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("vamp"), is_known = .true.)
call global%set_log (var_str ("?use_vamp_equivalences"),&
.true., is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%model_set_real (var_str ("ms"), &
0._default)
call flv%init (25, global%model)
name = flv%get_name ()
call global%beam_structure%init_sf ([name, name], [1])
call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))
call global%it_list%init ([1], [1000])
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call integrate_process (procname1, global, local_stack=.true.)
write (u, "(A)") "* Initialize event generation"
write (u, "(A)")
call reset_interaction_counter ()
call global%set_log (var_str ("?unweighted"), &
.false., is_known = .true.)
sample = "simulations6"
call global%set_string (var_str ("$sample"), &
sample, is_known = .true.)
allocate (simulation)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
write (u, "(A)") "* Initialize raw event file"
write (u, "(A)")
allocate (eio_raw_t :: eio)
call eio%init_out (sample)
write (u, "(A)") "* Generate an event"
write (u, "(A)")
call simulation%set_n_events_requested (1)
call simulation%generate ()
call pacify (simulation)
call simulation%write_event (u, verbose = .true., testflag = .true.)
call simulation%write_event (eio)
call eio%final ()
deallocate (eio)
call simulation%final ()
deallocate (simulation)
write (u, "(A)")
write (u, "(A)") "* Re-read the event from file"
write (u, "(A)")
call reset_interaction_counter ()
call global%set_log (var_str ("?update_sqme"), &
.true., is_known = .true.)
call global%set_log (var_str ("?update_weight"), &
.true., is_known = .true.)
allocate (simulation)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
allocate (eio_raw_t :: eio)
call eio%init_in (sample)
call simulation%read_event (eio)
call simulation%write_event (u, verbose = .true., testflag = .true.)
write (u, "(A)")
write (u, "(A)") "* Recalculate process instance"
write (u, "(A)")
call simulation%recalculate ()
call simulation%evaluate_expressions ()
call simulation%write_event (u, verbose = .true., testflag = .true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio%final ()
call simulation%final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_6"
end subroutine simulations_6
@ %def simulations_6
@
\subsubsection{Automatic Event I/O}
Generate events with raw-format event file as cache: generate, reread,
append.
<<Simulations: execute tests>>=
call test (simulations_7, "simulations_7", &
"automatic raw event I/O", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_7
<<Simulations: tests>>=
subroutine simulations_7 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname1, sample
type(rt_data_t), target :: global
type(string_t), dimension(0) :: empty_string_array
type(event_sample_data_t) :: data
type(event_stream_array_t) :: es_array
type(simulation_t), allocatable, target :: simulation
type(flavor_t) :: flv
type(string_t) :: name
write (u, "(A)") "* Test output: simulations_7"
write (u, "(A)") "* Purpose: generate events for a single process"
write (u, "(A)") "* write to file and reread"
write (u, "(A)")
write (u, "(A)") "* Initialize process and integrate"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%init_fallback_model &
(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
libname = "simulation_7"
procname1 = "simulation_7p"
call prepare_test_library (global, libname, 1, [procname1])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("wood"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("vamp"), is_known = .true.)
call global%set_log (var_str ("?use_vamp_equivalences"),&
.true., is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%model_set_real (var_str ("ms"), &
0._default)
call flv%init (25, global%model)
name = flv%get_name ()
call global%beam_structure%init_sf ([name, name], [1])
call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))
call global%it_list%init ([1], [1000])
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call integrate_process (procname1, global, local_stack=.true.)
write (u, "(A)") "* Initialize event generation"
write (u, "(A)")
call reset_interaction_counter ()
call global%set_log (var_str ("?unweighted"), &
.false., is_known = .true.)
sample = "simulations7"
call global%set_string (var_str ("$sample"), &
sample, is_known = .true.)
allocate (simulation)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
write (u, "(A)") "* Initialize raw event file"
write (u, "(A)")
data%md5sum_prc = simulation%get_md5sum_prc ()
data%md5sum_cfg = simulation%get_md5sum_cfg ()
call es_array%init (sample, [var_str ("raw")], global, data)
write (u, "(A)") "* Generate an event"
write (u, "(A)")
call simulation%set_n_events_requested (1)
call simulation%generate (es_array)
call es_array%final ()
call simulation%final ()
deallocate (simulation)
write (u, "(A)") "* Re-read the event from file and generate another one"
write (u, "(A)")
call global%set_log (&
var_str ("?rebuild_events"), .false., is_known = .true.)
call reset_interaction_counter ()
allocate (simulation)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
data%md5sum_prc = simulation%get_md5sum_prc ()
data%md5sum_cfg = simulation%get_md5sum_cfg ()
call es_array%init (sample, empty_string_array, global, data, &
input = var_str ("raw"))
call simulation%set_n_events_requested (2)
call simulation%generate (es_array)
call pacify (simulation)
call simulation%write_event (u, verbose = .true.)
call es_array%final ()
call simulation%final ()
deallocate (simulation)
write (u, "(A)")
write (u, "(A)") "* Re-read both events from file"
write (u, "(A)")
call reset_interaction_counter ()
allocate (simulation)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
data%md5sum_prc = simulation%get_md5sum_prc ()
data%md5sum_cfg = simulation%get_md5sum_cfg ()
call es_array%init (sample, empty_string_array, global, data, &
input = var_str ("raw"))
call simulation%set_n_events_requested (2)
call simulation%generate (es_array)
call pacify (simulation)
call simulation%write_event (u, verbose = .true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call es_array%final ()
call simulation%final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_7"
end subroutine simulations_7
@ %def simulations_7
@
\subsubsection{Rescanning Events}
Generate events and rescan the resulting raw event file.
<<Simulations: execute tests>>=
call test (simulations_8, "simulations_8", &
"rescan raw event file", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_8
<<Simulations: tests>>=
subroutine simulations_8 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname1, sample
type(rt_data_t), target :: global
type(string_t), dimension(0) :: empty_string_array
type(event_sample_data_t) :: data
type(event_stream_array_t) :: es_array
type(simulation_t), allocatable, target :: simulation
type(flavor_t) :: flv
type(string_t) :: name
write (u, "(A)") "* Test output: simulations_8"
write (u, "(A)") "* Purpose: generate events for a single process"
write (u, "(A)") "* write to file and rescan"
write (u, "(A)")
write (u, "(A)") "* Initialize process and integrate"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%init_fallback_model &
(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
libname = "simulation_8"
procname1 = "simulation_8p"
call prepare_test_library (global, libname, 1, [procname1])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("wood"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("vamp"), is_known = .true.)
call global%set_log (var_str ("?use_vamp_equivalences"),&
.true., is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%model_set_real (var_str ("ms"), &
0._default)
call flv%init (25, global%model)
name = flv%get_name ()
call global%beam_structure%init_sf ([name, name], [1])
call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))
call global%it_list%init ([1], [1000])
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call integrate_process (procname1, global, local_stack=.true.)
write (u, "(A)") "* Initialize event generation"
write (u, "(A)")
call reset_interaction_counter ()
call global%set_log (var_str ("?unweighted"), &
.false., is_known = .true.)
sample = "simulations8"
call global%set_string (var_str ("$sample"), &
sample, is_known = .true.)
allocate (simulation)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
write (u, "(A)") "* Initialize raw event file"
write (u, "(A)")
data%md5sum_prc = simulation%get_md5sum_prc ()
data%md5sum_cfg = simulation%get_md5sum_cfg ()
write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'"
write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'"
call es_array%init (sample, [var_str ("raw")], global, &
data)
write (u, "(A)")
write (u, "(A)") "* Generate an event"
write (u, "(A)")
call simulation%set_n_events_requested (1)
call simulation%generate (es_array)
call pacify (simulation)
call simulation%write_event (u, verbose = .true., testflag = .true.)
call es_array%final ()
call simulation%final ()
deallocate (simulation)
write (u, "(A)")
write (u, "(A)") "* Re-read the event from file"
write (u, "(A)")
call reset_interaction_counter ()
allocate (simulation)
call simulation%init ([procname1], .false., .false., global)
call simulation%init_process_selector ()
data%md5sum_prc = simulation%get_md5sum_prc ()
data%md5sum_cfg = ""
write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'"
write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'"
call es_array%init (sample, empty_string_array, global, data, &
input = var_str ("raw"), input_sample = sample, allow_switch = .false.)
call simulation%rescan (1, es_array, global = global)
write (u, "(A)")
call pacify (simulation)
call simulation%write_event (u, verbose = .true., testflag = .true.)
call es_array%final ()
call simulation%final ()
deallocate (simulation)
write (u, "(A)")
write (u, "(A)") "* Re-read again and recalculate"
write (u, "(A)")
call reset_interaction_counter ()
call global%set_log (var_str ("?update_sqme"), &
.true., is_known = .true.)
call global%set_log (var_str ("?update_event"), &
.true., is_known = .true.)
allocate (simulation)
call simulation%init ([procname1], .false., .false., global)
call simulation%init_process_selector ()
data%md5sum_prc = simulation%get_md5sum_prc ()
data%md5sum_cfg = ""
write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'"
write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'"
call es_array%init (sample, empty_string_array, global, data, &
input = var_str ("raw"), input_sample = sample, allow_switch = .false.)
call simulation%rescan (1, es_array, global = global)
write (u, "(A)")
call pacify (simulation)
call simulation%write_event (u, verbose = .true., testflag = .true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call es_array%final ()
call simulation%final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_8"
end subroutine simulations_8
@ %def simulations_8
@
\subsubsection{Rescanning Check}
Generate events and rescan with process mismatch.
<<Simulations: execute tests>>=
call test (simulations_9, "simulations_9", &
"rescan mismatch", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_9
<<Simulations: tests>>=
subroutine simulations_9 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname1, sample
type(rt_data_t), target :: global
type(string_t), dimension(0) :: empty_string_array
type(event_sample_data_t) :: data
type(event_stream_array_t) :: es_array
type(simulation_t), allocatable, target :: simulation
type(flavor_t) :: flv
type(string_t) :: name
logical :: error
write (u, "(A)") "* Test output: simulations_9"
write (u, "(A)") "* Purpose: generate events for a single process"
write (u, "(A)") "* write to file and rescan"
write (u, "(A)")
write (u, "(A)") "* Initialize process and integrate"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%init_fallback_model &
(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
libname = "simulation_9"
procname1 = "simulation_9p"
call prepare_test_library (global, libname, 1, [procname1])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("wood"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("vamp"), is_known = .true.)
call global%set_log (var_str ("?use_vamp_equivalences"),&
.true., is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%model_set_real (var_str ("ms"), &
0._default)
call flv%init (25, global%model)
name = flv%get_name ()
call global%beam_structure%init_sf ([name, name], [1])
call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))
call global%it_list%init ([1], [1000])
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call integrate_process (procname1, global, local_stack=.true.)
write (u, "(A)") "* Initialize event generation"
write (u, "(A)")
call reset_interaction_counter ()
call global%set_log (var_str ("?unweighted"), &
.false., is_known = .true.)
sample = "simulations9"
call global%set_string (var_str ("$sample"), &
sample, is_known = .true.)
allocate (simulation)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
call simulation%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize raw event file"
write (u, "(A)")
data%md5sum_prc = simulation%get_md5sum_prc ()
data%md5sum_cfg = simulation%get_md5sum_cfg ()
write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'"
write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'"
call es_array%init (sample, [var_str ("raw")], global, &
data)
write (u, "(A)")
write (u, "(A)") "* Generate an event"
write (u, "(A)")
call simulation%set_n_events_requested (1)
call simulation%generate (es_array)
call es_array%final ()
call simulation%final ()
deallocate (simulation)
write (u, "(A)") "* Initialize event generation for different parameters"
write (u, "(A)")
call reset_interaction_counter ()
allocate (simulation)
call simulation%init ([procname1, procname1], .false., .false., global)
call simulation%init_process_selector ()
call simulation%write (u)
write (u, "(A)")
write (u, "(A)") "* Attempt to re-read the events (should fail)"
write (u, "(A)")
data%md5sum_prc = simulation%get_md5sum_prc ()
data%md5sum_cfg = ""
write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'"
write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'"
call es_array%init (sample, empty_string_array, global, data, &
input = var_str ("raw"), input_sample = sample, &
allow_switch = .false., error = error)
write (u, "(1x,A,L1)") "error = ", error
call simulation%rescan (1, es_array, global = global)
call es_array%final ()
call simulation%final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_9"
end subroutine simulations_9
@ %def simulations_9
@
\subsubsection{Alternative weights}
Generate an event for a single process and reweight it in a
simultaneous calculation.
<<Simulations: execute tests>>=
call test (simulations_10, "simulations_10", &
"alternative weight", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_10
<<Simulations: tests>>=
subroutine simulations_10 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname1, expr_text
type(rt_data_t), target :: global
type(rt_data_t), dimension(1), target :: alt_env
type(ifile_t) :: ifile
type(stream_t) :: stream
type(parse_tree_t) :: pt_weight
type(simulation_t), target :: simulation
type(event_sample_data_t) :: data
write (u, "(A)") "* Test output: simulations_10"
write (u, "(A)") "* Purpose: reweight event"
write (u, "(A)")
write (u, "(A)") "* Initialize processes"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_pexpr_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
libname = "simulation_10a"
procname1 = "simulation_10p"
call prepare_test_library (global, libname, 1, [procname1])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%it_list%init ([1], [1000])
call global%set_string (var_str ("$run_id"), &
var_str ("simulations1"), is_known = .true.)
call integrate_process (procname1, global, local_stack=.true.)
write (u, "(A)") "* Initialize alternative environment with custom weight"
write (u, "(A)")
call alt_env(1)%local_init (global)
call alt_env(1)%activate ()
expr_text = "2"
write (u, "(A,A)") "weight = ", char (expr_text)
write (u, *)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_expr (pt_weight, stream, .true.)
call stream_final (stream)
alt_env(1)%pn%weight_expr => pt_weight%get_root_ptr ()
call alt_env(1)%write_expr (u)
write (u, "(A)")
write (u, "(A)") "* Initialize event generation"
write (u, "(A)")
call global%set_log (var_str ("?unweighted"), &
.false., is_known = .true.)
call simulation%init ([procname1], .true., .true., global, alt_env=alt_env)
call simulation%init_process_selector ()
data = simulation%get_data ()
call data%write (u)
write (u, "(A)")
write (u, "(A)") "* Generate an event"
write (u, "(A)")
call simulation%set_n_events_requested (1)
call simulation%generate ()
call simulation%write (u)
write (u, "(A)")
write (u, "(A)") "* Write the event record for the last event"
write (u, "(A)")
call simulation%write_event (u)
write (u, "(A)")
write (u, "(A)") "* Write the event record for the alternative setup"
write (u, "(A)")
call simulation%write_alt_event (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call simulation%final ()
call global%final ()
call syntax_model_file_final ()
call syntax_pexpr_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_10"
end subroutine simulations_10
@ %def simulations_10
@
\subsubsection{Decays}
Generate an event with subsequent partonic decays.
<<Simulations: execute tests>>=
call test (simulations_11, "simulations_11", &
"decay", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_11
<<Simulations: tests>>=
subroutine simulations_11 (u)
integer, intent(in) :: u
type(rt_data_t), target :: global
type(prclib_entry_t), pointer :: lib
type(string_t) :: prefix, procname1, procname2
type(simulation_t), target :: simulation
write (u, "(A)") "* Test output: simulations_11"
write (u, "(A)") "* Purpose: apply decay"
write (u, "(A)")
write (u, "(A)") "* Initialize processes"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
allocate (lib)
call global%add_prclib (lib)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
prefix = "simulation_11"
procname1 = prefix // "_p"
procname2 = prefix // "_d"
call prepare_testbed &
(global%prclib, global%process_stack, &
prefix, global%os_data, &
scattering=.true., decay=.true.)
call global%select_model (var_str ("Test"))
call global%model%set_par (var_str ("ff"), 0.4_default)
call global%model%set_par (var_str ("mf"), &
global%model%get_real (var_str ("ff")) &
* global%model%get_real (var_str ("ms")))
call global%model%set_unstable (25, [procname2])
write (u, "(A)") "* Initialize simulation object"
write (u, "(A)")
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
write (u, "(A)") "* Generate event"
write (u, "(A)")
call simulation%set_n_events_requested (1)
call simulation%generate ()
call simulation%write (u)
write (u, *)
call simulation%write_event (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
write (u, "(A)")
call simulation%final ()
call global%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_11"
end subroutine simulations_11
@ %def simulations_11
@
\subsubsection{Split Event Files}
Generate event for a real process with structure functions and write to file,
accepting a limit for the number of events per file.
<<Simulations: execute tests>>=
call test (simulations_12, "simulations_12", &
"split event files", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_12
<<Simulations: tests>>=
subroutine simulations_12 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname1, sample
type(rt_data_t), target :: global
class(eio_t), allocatable :: eio
type(simulation_t), allocatable, target :: simulation
type(flavor_t) :: flv
integer :: i_evt
write (u, "(A)") "* Test output: simulations_12"
write (u, "(A)") "* Purpose: generate events for a single process"
write (u, "(A)") "* and write to split event files"
write (u, "(A)")
write (u, "(A)") "* Initialize process and integrate"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
libname = "simulation_12"
procname1 = "simulation_12p"
call prepare_test_library (global, libname, 1, [procname1])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%model_set_real (var_str ("ms"), &
0._default)
call flv%init (25, global%model)
call global%it_list%init ([1], [1000])
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call integrate_process (procname1, global, local_stack=.true.)
write (u, "(A)") "* Initialize event generation"
write (u, "(A)")
call global%set_log (var_str ("?unweighted"), &
.false., is_known = .true.)
sample = "simulations_12"
call global%set_string (var_str ("$sample"), &
sample, is_known = .true.)
call global%set_int (var_str ("sample_split_n_evt"), &
2, is_known = .true.)
call global%set_int (var_str ("sample_split_index"), &
42, is_known = .true.)
allocate (simulation)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
call simulation%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize ASCII event file"
write (u, "(A)")
allocate (eio_ascii_short_t :: eio)
select type (eio)
class is (eio_ascii_t); call eio%set_parameters ()
end select
call eio%init_out (sample, data = simulation%get_data ())
write (u, "(A)") "* Generate 5 events, distributed among three files"
do i_evt = 1, 5
call simulation%set_n_events_requested (1)
call simulation%generate ()
call simulation%write_event (eio)
end do
call eio%final ()
deallocate (eio)
call simulation%final ()
deallocate (simulation)
write (u, *)
call display_file ("simulations_12.42.short.evt", u)
write (u, *)
call display_file ("simulations_12.43.short.evt", u)
write (u, *)
call display_file ("simulations_12.44.short.evt", u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_12"
end subroutine simulations_12
@ %def simulations_12
@ Auxiliary: display file contents.
<<Simulations: public test auxiliary>>=
public :: display_file
<<Simulations: test auxiliary>>=
subroutine display_file (file, u)
use io_units, only: free_unit
character(*), intent(in) :: file
integer, intent(in) :: u
character(256) :: buffer
integer :: u_file
write (u, "(3A)") "* Contents of file '", file, "':"
write (u, *)
u_file = free_unit ()
open (u_file, file = file, action = "read", status = "old")
do
read (u_file, "(A)", end = 1) buffer
write (u, "(A)") trim (buffer)
end do
1 continue
end subroutine display_file
@ %def display_file
@
\subsubsection{Callback}
Generate events and execute a callback in place of event I/O.
<<Simulations: execute tests>>=
call test (simulations_13, "simulations_13", &
"callback", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_13
<<Simulations: tests>>=
subroutine simulations_13 (u)
integer, intent(in) :: u
type(string_t) :: libname, procname1, sample
type(rt_data_t), target :: global
class(eio_t), allocatable :: eio
type(simulation_t), allocatable, target :: simulation
type(flavor_t) :: flv
integer :: i_evt
type(simulations_13_callback_t) :: event_callback
write (u, "(A)") "* Test output: simulations_13"
write (u, "(A)") "* Purpose: generate events for a single process"
write (u, "(A)") "* and execute callback"
write (u, "(A)")
write (u, "(A)") "* Initialize process and integrate"
write (u, "(A)")
call syntax_model_file_init ()
call global%global_init ()
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
libname = "simulation_13"
procname1 = "simulation_13p"
call prepare_test_library (global, libname, 1, [procname1])
call compile_library (libname, global)
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known = .true.)
call global%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call global%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known = .true.)
call global%set_log (var_str ("?vis_history"),&
.false., is_known = .true.)
call global%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call flv%init (25, global%model)
call global%it_list%init ([1], [1000])
call global%set_string (var_str ("$run_id"), &
var_str ("r1"), is_known = .true.)
call integrate_process (procname1, global, local_stack=.true.)
write (u, "(A)") "* Initialize event generation"
write (u, "(A)")
call global%set_log (var_str ("?unweighted"), &
.false., is_known = .true.)
sample = "simulations_13"
call global%set_string (var_str ("$sample"), &
sample, is_known = .true.)
allocate (simulation)
call simulation%init ([procname1], .true., .true., global)
call simulation%init_process_selector ()
write (u, "(A)") "* Prepare callback object"
write (u, "(A)")
event_callback%u = u
call global%set_event_callback (event_callback)
write (u, "(A)") "* Initialize callback I/O object"
write (u, "(A)")
allocate (eio_callback_t :: eio)
select type (eio)
class is (eio_callback_t)
call eio%set_parameters (callback = event_callback, &
count_interval = 3)
end select
call eio%init_out (sample, data = simulation%get_data ())
write (u, "(A)") "* Generate 7 events, with callback every 3 events"
write (u, "(A)")
do i_evt = 1, 7
call simulation%set_n_events_requested (1)
call simulation%generate ()
call simulation%write_event (eio)
end do
call eio%final ()
deallocate (eio)
call simulation%final ()
deallocate (simulation)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_13"
end subroutine simulations_13
@ %def simulations_13
@ The callback object and procedure. In the type extension, we can
store the output channel [[u]] so we know where to write into.
<<Simulations: test auxiliary types>>=
type, extends (event_callback_t) :: simulations_13_callback_t
integer :: u
contains
procedure :: write => simulations_13_callback_write
procedure :: proc => simulations_13_callback
end type simulations_13_callback_t
@ %def simulations_13_callback_t
<<Simulations: test auxiliary>>=
subroutine simulations_13_callback_write (event_callback, unit)
class(simulations_13_callback_t), intent(in) :: event_callback
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Hello"
end subroutine simulations_13_callback_write
subroutine simulations_13_callback (event_callback, i, event)
class(simulations_13_callback_t), intent(in) :: event_callback
integer(i64), intent(in) :: i
class(generic_event_t), intent(in) :: event
write (event_callback%u, "(A,I0)") "hello event #", i
end subroutine simulations_13_callback
@ %def simulations_13_callback_write
@ %def simulations_13_callback
@
\subsubsection{Resonant subprocess setup}
Prepare a process with resonances and enter resonant subprocesses in
the simulation object. Select a kinematics configuration and compute
probabilities for resonant subprocesses.
The process and its initialization is taken from [[processes_18]], but
we need a complete \oMega\ matrix element here.
<<Simulations: execute tests>>=
call test (simulations_14, "simulations_14", &
"resonant subprocesses evaluation", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_14
<<Simulations: tests>>=
subroutine simulations_14 (u)
integer, intent(in) :: u
type(string_t) :: libname, libname_generated
type(string_t) :: procname
type(string_t) :: model_name
type(rt_data_t), target :: global
type(prclib_entry_t), pointer :: lib_entry
type(process_library_t), pointer :: lib
class(model_t), pointer :: model
class(model_data_t), pointer :: model_data
type(simulation_t), target :: simulation
type(particle_set_t) :: pset
type(eio_direct_t) :: eio_in
type(eio_dump_t) :: eio_out
real(default) :: sqrts, mw, pp
real(default), dimension(3) :: p3
type(vector4_t), dimension(:), allocatable :: p
real(default), dimension(:), allocatable :: m
integer :: u_verbose, i
real(default) :: sqme_proc
real(default), dimension(:), allocatable :: sqme
real(default) :: on_shell_limit
integer, dimension(:), allocatable :: i_array
real(default), dimension(:), allocatable :: prob_array
write (u, "(A)") "* Test output: simulations_14"
write (u, "(A)") "* Purpose: construct resonant subprocesses &
&in the simulation object"
write (u, "(A)")
write (u, "(A)") "* Build and load a test library with one process"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_phs_forest_init ()
libname = "simulations_14_lib"
procname = "simulations_14_p"
call global%global_init ()
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_log (var_str ("?update_sqme"), &
.true., is_known = .true.)
call global%set_log (var_str ("?update_weight"), &
.true., is_known = .true.)
call global%set_log (var_str ("?update_event"), &
.true., is_known = .true.)
model_name = "SM"
call global%select_model (model_name)
allocate (model)
call model%init_instance (global%model)
model_data => model
write (u, "(A)") "* Initialize process library and process"
write (u, "(A)")
allocate (lib_entry)
call lib_entry%init (libname)
lib => lib_entry%process_library_t
call global%add_prclib (lib_entry)
call prepare_resonance_test_library &
(lib, libname, procname, model_data, global, u)
write (u, "(A)")
write (u, "(A)") "* Initialize simulation object &
&with resonant subprocesses"
write (u, "(A)")
call global%set_log (var_str ("?resonance_history"), &
.true., is_known = .true.)
call global%set_real (var_str ("resonance_on_shell_limit"), &
10._default, is_known = .true.)
call simulation%init ([procname], &
integrate=.false., generate=.false., local=global)
call simulation%write_resonant_subprocess_data (u, 1)
write (u, "(A)")
write (u, "(A)") "* Resonant subprocesses: generated library"
write (u, "(A)")
libname_generated = procname // "_R"
lib => global%prclib_stack%get_library_ptr (libname_generated)
if (associated (lib)) call lib%write (u, libpath=.false.)
write (u, "(A)")
write (u, "(A)") "* Generated process stack"
write (u, "(A)")
call global%process_stack%show (u)
write (u, "(A)")
write (u, "(A)") "* Particle set"
write (u, "(A)")
pset = simulation%get_hard_particle_set (1)
call pset%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize object for direct access"
write (u, "(A)")
call eio_in%init_direct &
(n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 3, &
pdg = [-11, 11, 1, -2, 24], model=global%model)
call eio_in%set_selection_indices (1, 1, 1, 1)
sqrts = global%get_rval (var_str ("sqrts"))
mw = 80._default ! deliberately slightly different from true mw
pp = sqrt (sqrts**2 - 4 * mw**2) / 2
allocate (p (5), m (5))
p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
m(1) = 0
p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
m(2) = 0
p3(1) = pp/2
p3(2) = mw/2
p3(3) = 0
p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
m(3) = 0
p3(2) = -mw/2
p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
m(4) = 0
p(5) = vector4_moving (sqrts/2,-pp, 1)
m(5) = mw
call eio_in%set_momentum (p, m**2)
call eio_in%write (u)
write (u, "(A)")
write (u, "(A)") "* Transfer and show particle set"
write (u, "(A)")
call simulation%read_event (eio_in)
pset = simulation%get_hard_particle_set (1)
call pset%write (u)
write (u, "(A)")
write (u, "(A)") "* (Re)calculate matrix element"
write (u, "(A)")
call simulation%recalculate (recover_phs = .false.)
call simulation%evaluate_transforms ()
write (u, "(A)") "* Show event with sqme"
write (u, "(A)")
call eio_out%set_parameters (unit = u, &
weights = .true., pacify = .true., compressed = .true.)
call eio_out%init_out (var_str (""))
call simulation%write_event (eio_out)
write (u, "(A)")
write (u, "(A)") "* Write event to separate file &
&'simulations_14_event_verbose.log'"
u_verbose = free_unit ()
open (unit = u_verbose, file = "simulations_14_event_verbose.log", &
status = "replace", action = "write")
call simulation%write (u_verbose)
write (u_verbose, *)
call simulation%write_event (u_verbose, verbose =.true., testflag = .true.)
close (u_verbose)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call simulation%final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_14"
end subroutine simulations_14
@ %def simulations_14
@
\subsubsection{Resonant subprocess simulation}
Prepare a process with resonances and enter resonant subprocesses in
the simulation object. Simulate events with selection of resonance
histories.
The process and its initialization is taken from [[processes_18]], but
we need a complete \oMega\ matrix element here.
<<Simulations: execute tests>>=
call test (simulations_15, "simulations_15", &
"resonant subprocesses in simulation", &
u, results)
<<Simulations: test declarations>>=
public :: simulations_15
<<Simulations: tests>>=
subroutine simulations_15 (u)
integer, intent(in) :: u
type(string_t) :: libname, libname_generated
type(string_t) :: procname
type(string_t) :: model_name
type(rt_data_t), target :: global
type(prclib_entry_t), pointer :: lib_entry
type(process_library_t), pointer :: lib
class(model_t), pointer :: model
class(model_data_t), pointer :: model_data
type(simulation_t), target :: simulation
real(default) :: sqrts
type(eio_dump_t) :: eio_out
integer :: u_verbose
write (u, "(A)") "* Test output: simulations_15"
write (u, "(A)") "* Purpose: generate event with resonant subprocess"
write (u, "(A)")
write (u, "(A)") "* Build and load a test library with one process"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_phs_forest_init ()
libname = "simulations_15_lib"
procname = "simulations_15_p"
call global%global_init ()
call global%append_log (&
var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_grids"), .true., intrinsic = .true.)
call global%append_log (&
var_str ("?rebuild_events"), .true., intrinsic = .true.)
call global%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
call global%set_int (var_str ("seed"), &
0, is_known = .true.)
call global%set_real (var_str ("sqrts"),&
1000._default, is_known = .true.)
call global%set_log (var_str ("?recover_beams"), &
.false., is_known = .true.)
call global%set_log (var_str ("?update_sqme"), &
.true., is_known = .true.)
call global%set_log (var_str ("?update_weight"), &
.true., is_known = .true.)
call global%set_log (var_str ("?update_event"), &
.true., is_known = .true.)
call global%set_log (var_str ("?resonance_history"), &
.true., is_known = .true.)
call global%set_real (var_str ("resonance_on_shell_limit"), &
10._default, is_known = .true.)
model_name = "SM"
call global%select_model (model_name)
allocate (model)
call model%init_instance (global%model)
model_data => model
write (u, "(A)") "* Initialize process library and process"
write (u, "(A)")
allocate (lib_entry)
call lib_entry%init (libname)
lib => lib_entry%process_library_t
call global%add_prclib (lib_entry)
call prepare_resonance_test_library &
(lib, libname, procname, model_data, global, u)
write (u, "(A)")
write (u, "(A)") "* Initialize simulation object &
&with resonant subprocesses"
write (u, "(A)")
call global%it_list%init ([1], [1000])
call simulation%init ([procname], &
integrate=.true., generate=.true., local=global)
call simulation%write_resonant_subprocess_data (u, 1)
write (u, "(A)")
write (u, "(A)") "* Generate event"
write (u, "(A)")
call simulation%init_process_selector ()
call simulation%set_n_events_requested (1)
call simulation%generate ()
call eio_out%set_parameters (unit = u, &
weights = .true., pacify = .true., compressed = .true.)
call eio_out%init_out (var_str (""))
call simulation%write_event (eio_out)
write (u, "(A)")
write (u, "(A)") "* Write event to separate file &
&'simulations_15_event_verbose.log'"
u_verbose = free_unit ()
open (unit = u_verbose, file = "simulations_15_event_verbose.log", &
status = "replace", action = "write")
call simulation%write (u_verbose)
write (u_verbose, *)
call simulation%write_event (u_verbose, verbose =.true., testflag = .true.)
close (u_verbose)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call simulation%final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: simulations_15"
end subroutine simulations_15
@ %def simulations_15
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{More Unit Tests}
This chapter collects some procedures for testing that can't be
provided at the point where the corresponding modules are defined,
because they use other modules of a different level.
(We should move them back, collecting the high-level functionality in
init/final hooks that we can set at runtime.)
\section{Expression Testing}
Expression objects are part of process and event objects, but the
process and event object modules should not depend on the
implementation of expressions. Here, we collect unit tests that
depend on expression implementation.
<<[[expr_tests_ut.f90]]>>=
<<File header>>
module expr_tests_ut
use unit_tests
use expr_tests_uti
<<Standard module head>>
<<Expr tests: public test>>
contains
<<Expr tests: test driver>>
end module expr_tests_ut
@ %def expr_tests_ut
@
<<[[expr_tests_uti.f90]]>>=
<<File header>>
module expr_tests_uti
<<Use kinds>>
<<Use strings>>
use format_defs, only: FMT_12
use format_utils, only: write_separator
use os_interface
use sm_qcd
use lorentz
use ifiles
use lexers
use parser
use model_data
use interactions, only: reset_interaction_counter
use process_libraries
use subevents
use subevt_expr
use rng_base
use mci_base
use phs_base
use variables, only: var_list_t
use eval_trees
use models
use prc_core
use prc_test
use process, only: process_t
use instances, only: process_instance_t
use events
use rng_base_ut, only: rng_test_factory_t
use phs_base_ut, only: phs_test_config_t
<<Standard module head>>
<<Expr tests: test declarations>>
contains
<<Expr tests: tests>>
<<Expr tests: test auxiliary>>
end module expr_tests_uti
@ %def expr_tests_uti
@
\subsection{Test}
This is the master for calling self-test procedures.
<<Expr tests: public test>>=
public :: subevt_expr_test
<<Expr tests: test driver>>=
subroutine subevt_expr_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Expr tests: execute tests>>
end subroutine subevt_expr_test
@ %def subevt_expr_test
@
\subsubsection{Parton-event expressions}
<<Expr tests: execute tests>>=
call test (subevt_expr_1, "subevt_expr_1", &
"parton-event expressions", &
u, results)
<<Expr tests: test declarations>>=
public :: subevt_expr_1
<<Expr tests: tests>>=
subroutine subevt_expr_1 (u)
integer, intent(in) :: u
type(string_t) :: expr_text
type(ifile_t) :: ifile
type(stream_t) :: stream
type(parse_tree_t) :: pt_cuts, pt_scale, pt_fac_scale, pt_ren_scale
type(parse_tree_t) :: pt_weight
type(parse_node_t), pointer :: pn_cuts, pn_scale, pn_fac_scale, pn_ren_scale
type(parse_node_t), pointer :: pn_weight
type(eval_tree_factory_t) :: expr_factory
type(os_data_t) :: os_data
type(model_t), target :: model
type(parton_expr_t), target :: expr
real(default) :: E, Ex, m
type(vector4_t), dimension(6) :: p
integer :: i, pdg
logical :: passed
real(default) :: scale, weight
real(default), allocatable :: fac_scale, ren_scale
write (u, "(A)") "* Test output: subevt_expr_1"
write (u, "(A)") "* Purpose: Set up a subevt and associated &
&process-specific expressions"
write (u, "(A)")
call syntax_pexpr_init ()
call syntax_model_file_init ()
call os_data%init ()
call model%read (var_str ("Test.mdl"), os_data)
write (u, "(A)") "* Expression texts"
write (u, "(A)")
expr_text = "all Pt > 100 [s]"
write (u, "(A,A)") "cuts = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_lexpr (pt_cuts, stream, .true.)
call stream_final (stream)
pn_cuts => pt_cuts%get_root_ptr ()
expr_text = "sqrts"
write (u, "(A,A)") "scale = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_expr (pt_scale, stream, .true.)
call stream_final (stream)
pn_scale => pt_scale%get_root_ptr ()
expr_text = "sqrts_hat"
write (u, "(A,A)") "fac_scale = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_expr (pt_fac_scale, stream, .true.)
call stream_final (stream)
pn_fac_scale => pt_fac_scale%get_root_ptr ()
expr_text = "100"
write (u, "(A,A)") "ren_scale = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_expr (pt_ren_scale, stream, .true.)
call stream_final (stream)
pn_ren_scale => pt_ren_scale%get_root_ptr ()
expr_text = "n_tot - n_in - n_out"
write (u, "(A,A)") "weight = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_expr (pt_weight, stream, .true.)
call stream_final (stream)
pn_weight => pt_weight%get_root_ptr ()
call ifile_final (ifile)
write (u, "(A)")
write (u, "(A)") "* Initialize process expr"
write (u, "(A)")
call expr%setup_vars (1000._default)
call expr%var_list%append_real (var_str ("tolerance"), 0._default)
call expr%link_var_list (model%get_var_list_ptr ())
call expr_factory%init (pn_cuts)
call expr%setup_selection (expr_factory)
call expr_factory%init (pn_scale)
call expr%setup_scale (expr_factory)
call expr_factory%init (pn_fac_scale)
call expr%setup_fac_scale (expr_factory)
call expr_factory%init (pn_ren_scale)
call expr%setup_ren_scale (expr_factory)
call expr_factory%init (pn_weight)
call expr%setup_weight (expr_factory)
call write_separator (u)
call expr%write (u)
call write_separator (u)
write (u, "(A)")
write (u, "(A)") "* Fill subevt and evaluate expressions"
write (u, "(A)")
call subevt_init (expr%subevt_t, 6)
E = 500._default
Ex = 400._default
m = 125._default
pdg = 25
p(1) = vector4_moving (E, sqrt (E**2 - m**2), 3)
p(2) = vector4_moving (E, -sqrt (E**2 - m**2), 3)
p(3) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 3)
p(4) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 3)
p(5) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 1)
p(6) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 1)
call expr%reset_contents ()
do i = 1, 2
call expr%set_beam (i, pdg, p(i), m**2)
end do
do i = 3, 4
call expr%set_incoming (i, pdg, p(i), m**2)
end do
do i = 5, 6
call expr%set_outgoing (i, pdg, p(i), m**2)
end do
expr%sqrts_hat = expr%get_sqrts_hat ()
expr%n_in = 2
expr%n_out = 2
expr%n_tot = 4
expr%subevt_filled = .true.
call expr%evaluate (passed, scale, fac_scale, ren_scale, weight)
write (u, "(A,L1)") "Event has passed = ", passed
write (u, "(A," // FMT_12 // ")") "Scale = ", scale
write (u, "(A," // FMT_12 // ")") "Factorization scale = ", fac_scale
write (u, "(A," // FMT_12 // ")") "Renormalization scale = ", ren_scale
write (u, "(A," // FMT_12 // ")") "Weight = ", weight
write (u, "(A)")
call write_separator (u)
call expr%write (u)
call write_separator (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call expr%final ()
call model%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: subevt_expr_1"
end subroutine subevt_expr_1
@ %def subevt_expr_1
@
\subsubsection{Parton-event expressions}
<<Expr tests: execute tests>>=
call test (subevt_expr_2, "subevt_expr_2", &
"parton-event expressions", &
u, results)
<<Expr tests: test declarations>>=
public :: subevt_expr_2
<<Expr tests: tests>>=
subroutine subevt_expr_2 (u)
integer, intent(in) :: u
type(string_t) :: expr_text
type(ifile_t) :: ifile
type(stream_t) :: stream
type(parse_tree_t) :: pt_selection
type(parse_tree_t) :: pt_reweight, pt_analysis
type(parse_node_t), pointer :: pn_selection
type(parse_node_t), pointer :: pn_reweight, pn_analysis
type(os_data_t) :: os_data
type(model_t), target :: model
type(eval_tree_factory_t) :: expr_factory
type(event_expr_t), target :: expr
real(default) :: E, Ex, m
type(vector4_t), dimension(6) :: p
integer :: i, pdg
logical :: passed
real(default) :: reweight
logical :: analysis_flag
write (u, "(A)") "* Test output: subevt_expr_2"
write (u, "(A)") "* Purpose: Set up a subevt and associated &
&process-specific expressions"
write (u, "(A)")
call syntax_pexpr_init ()
call syntax_model_file_init ()
call os_data%init ()
call model%read (var_str ("Test.mdl"), os_data)
write (u, "(A)") "* Expression texts"
write (u, "(A)")
expr_text = "all Pt > 100 [s]"
write (u, "(A,A)") "selection = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_lexpr (pt_selection, stream, .true.)
call stream_final (stream)
pn_selection => pt_selection%get_root_ptr ()
expr_text = "n_tot - n_in - n_out"
write (u, "(A,A)") "reweight = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_expr (pt_reweight, stream, .true.)
call stream_final (stream)
pn_reweight => pt_reweight%get_root_ptr ()
expr_text = "true"
write (u, "(A,A)") "analysis = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_lexpr (pt_analysis, stream, .true.)
call stream_final (stream)
pn_analysis => pt_analysis%get_root_ptr ()
call ifile_final (ifile)
write (u, "(A)")
write (u, "(A)") "* Initialize process expr"
write (u, "(A)")
call expr%setup_vars (1000._default)
call expr%link_var_list (model%get_var_list_ptr ())
call expr%var_list%append_real (var_str ("tolerance"), 0._default)
call expr_factory%init (pn_selection)
call expr%setup_selection (expr_factory)
call expr_factory%init (pn_analysis)
call expr%setup_analysis (expr_factory)
call expr_factory%init (pn_reweight)
call expr%setup_reweight (expr_factory)
call write_separator (u)
call expr%write (u)
call write_separator (u)
write (u, "(A)")
write (u, "(A)") "* Fill subevt and evaluate expressions"
write (u, "(A)")
call subevt_init (expr%subevt_t, 6)
E = 500._default
Ex = 400._default
m = 125._default
pdg = 25
p(1) = vector4_moving (E, sqrt (E**2 - m**2), 3)
p(2) = vector4_moving (E, -sqrt (E**2 - m**2), 3)
p(3) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 3)
p(4) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 3)
p(5) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 1)
p(6) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 1)
call expr%reset_contents ()
do i = 1, 2
call expr%set_beam (i, pdg, p(i), m**2)
end do
do i = 3, 4
call expr%set_incoming (i, pdg, p(i), m**2)
end do
do i = 5, 6
call expr%set_outgoing (i, pdg, p(i), m**2)
end do
expr%sqrts_hat = expr%get_sqrts_hat ()
expr%n_in = 2
expr%n_out = 2
expr%n_tot = 4
expr%subevt_filled = .true.
call expr%evaluate (passed, reweight, analysis_flag)
write (u, "(A,L1)") "Event has passed = ", passed
write (u, "(A," // FMT_12 // ")") "Reweighting factor = ", reweight
write (u, "(A,L1)") "Analysis flag = ", analysis_flag
write (u, "(A)")
call write_separator (u)
call expr%write (u)
call write_separator (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call expr%final ()
call model%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: subevt_expr_2"
end subroutine subevt_expr_2
@ %def subevt_expr_2
@
\subsubsection{Processes: handle partonic cuts}
Initialize a process and process instance, choose a sampling point and
fill the process instance, evaluating a given cut configuration.
We use the same trivial process as for the previous test. All
momentum and state dependence is trivial, so we just test basic
functionality.
<<Expr tests: execute tests>>=
call test (processes_5, "processes_5", &
"handle cuts (partonic event)", &
u, results)
<<Expr tests: test declarations>>=
public :: processes_5
<<Expr tests: tests>>=
subroutine processes_5 (u)
integer, intent(in) :: u
type(string_t) :: cut_expr_text
type(ifile_t) :: ifile
type(stream_t) :: stream
type(parse_tree_t) :: parse_tree
type(eval_tree_factory_t) :: expr_factory
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), pointer :: model_tmp
type(model_t), pointer :: model
type(var_list_t), target :: var_list
type(process_t), allocatable, target :: process
class(phs_config_t), allocatable :: phs_config_template
real(default) :: sqrts
type(process_instance_t), allocatable, target :: process_instance
write (u, "(A)") "* Test output: processes_5"
write (u, "(A)") "* Purpose: create a process &
&and fill a process instance"
write (u, "(A)")
write (u, "(A)") "* Prepare a cut expression"
write (u, "(A)")
call syntax_pexpr_init ()
cut_expr_text = "all Pt > 100 [s]"
call ifile_append (ifile, cut_expr_text)
call stream_init (stream, ifile)
call parse_tree_init_lexpr (parse_tree, stream, .true.)
write (u, "(A)") "* Build and initialize a test process"
write (u, "(A)")
libname = "processes5"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
call syntax_model_file_init ()
allocate (model_tmp)
call model_tmp%read (var_str ("Test.mdl"), os_data)
call var_list%init_snapshot (model_tmp%get_var_list_ptr ())
model => model_tmp
call reset_interaction_counter ()
call var_list%append_real (var_str ("tolerance"), 0._default)
call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
call var_list%append_int (var_str ("seed"), 0)
allocate (process)
call process%init (procname, lib, os_data, model, var_list)
call var_list%final ()
allocate (phs_test_config_t :: phs_config_template)
call process%setup_test_cores ()
call process%init_components (phs_config_template)
write (u, "(A)") "* Prepare a trivial beam setup"
write (u, "(A)")
sqrts = 1000
call process%setup_beams_sqrts (sqrts, i_core = 1)
call process%configure_phs ()
call process%setup_mci (dispatch_mci_empty)
write (u, "(A)") "* Complete process initialization and set cuts"
write (u, "(A)")
call process%setup_terms ()
call expr_factory%init (parse_tree%get_root_ptr ())
call process%set_cuts (expr_factory)
call process%write (.false., u, &
show_var_list=.true., show_expressions=.true., show_os_data=.false.)
write (u, "(A)")
write (u, "(A)") "* Create a process instance"
write (u, "(A)")
allocate (process_instance)
call process_instance%init (process)
write (u, "(A)")
write (u, "(A)") "* Inject a set of random numbers"
write (u, "(A)")
call process_instance%choose_mci (1)
call process_instance%set_mcpar ([0._default, 0._default])
write (u, "(A)")
write (u, "(A)") "* Set up kinematics and subevt, check cuts (should fail)"
write (u, "(A)")
call process_instance%select_channel (1)
call process_instance%compute_seed_kinematics ()
call process_instance%compute_hard_kinematics ()
call process_instance%compute_eff_kinematics ()
call process_instance%evaluate_expressions ()
call process_instance%compute_other_channels ()
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Evaluate for another set (should succeed)"
write (u, "(A)")
call process_instance%reset ()
call process_instance%set_mcpar ([0.5_default, 0.125_default])
call process_instance%select_channel (1)
call process_instance%compute_seed_kinematics ()
call process_instance%compute_hard_kinematics ()
call process_instance%compute_eff_kinematics ()
call process_instance%evaluate_expressions ()
call process_instance%compute_other_channels ()
call process_instance%evaluate_trace ()
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Evaluate for another set using convenience procedure &
&(failure)"
write (u, "(A)")
call process_instance%evaluate_sqme (1, [0.0_default, 0.2_default])
call process_instance%write_header (u)
write (u, "(A)")
write (u, "(A)") "* Evaluate for another set using convenience procedure &
&(success)"
write (u, "(A)")
call process_instance%evaluate_sqme (1, [0.1_default, 0.2_default])
call process_instance%write_header (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process_instance%final ()
deallocate (process_instance)
call process%final ()
deallocate (process)
call parse_tree_final (parse_tree)
call stream_final (stream)
call ifile_final (ifile)
call syntax_pexpr_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_5"
end subroutine processes_5
@ %def processes_5
@ Trivial for testing: do not allocate the MCI record.
<<Expr tests: test auxiliary>>=
subroutine dispatch_mci_empty (mci, var_list, process_id, is_nlo)
class(mci_t), allocatable, intent(out) :: mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
logical, intent(in), optional :: is_nlo
end subroutine dispatch_mci_empty
@ %def dispatch_mci_empty
@
\subsubsection{Processes: scales and such}
Initialize a process and process instance, choose a sampling point and
fill the process instance, evaluating a given cut configuration.
We use the same trivial process as for the previous test. All
momentum and state dependence is trivial, so we just test basic
functionality.
<<Expr tests: execute tests>>=
call test (processes_6, "processes_6", &
"handle scales and weight (partonic event)", &
u, results)
<<Expr tests: test declarations>>=
public :: processes_6
<<Expr tests: tests>>=
subroutine processes_6 (u)
integer, intent(in) :: u
type(string_t) :: expr_text
type(ifile_t) :: ifile
type(stream_t) :: stream
type(parse_tree_t) :: pt_scale, pt_fac_scale, pt_ren_scale, pt_weight
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), pointer :: model_tmp
type(model_t), pointer :: model
type(var_list_t), target :: var_list
type(process_t), allocatable, target :: process
class(phs_config_t), allocatable :: phs_config_template
real(default) :: sqrts
type(process_instance_t), allocatable, target :: process_instance
type(eval_tree_factory_t) :: expr_factory
write (u, "(A)") "* Test output: processes_6"
write (u, "(A)") "* Purpose: create a process &
&and fill a process instance"
write (u, "(A)")
write (u, "(A)") "* Prepare expressions"
write (u, "(A)")
call syntax_pexpr_init ()
expr_text = "sqrts - 100 GeV"
write (u, "(A,A)") "scale = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_expr (pt_scale, stream, .true.)
call stream_final (stream)
expr_text = "sqrts_hat"
write (u, "(A,A)") "fac_scale = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_expr (pt_fac_scale, stream, .true.)
call stream_final (stream)
expr_text = "eval sqrt (M2) [collect [s]]"
write (u, "(A,A)") "ren_scale = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_expr (pt_ren_scale, stream, .true.)
call stream_final (stream)
expr_text = "n_tot * n_in * n_out * (eval Phi / pi [s])"
write (u, "(A,A)") "weight = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_expr (pt_weight, stream, .true.)
call stream_final (stream)
call ifile_final (ifile)
write (u, "(A)")
write (u, "(A)") "* Build and initialize a test process"
write (u, "(A)")
libname = "processes4"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
call syntax_model_file_init ()
allocate (model_tmp)
call model_tmp%read (var_str ("Test.mdl"), os_data)
call var_list%init_snapshot (model_tmp%get_var_list_ptr ())
model => model_tmp
call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
call var_list%append_int (var_str ("seed"), 0)
call reset_interaction_counter ()
allocate (process)
call process%init (procname, lib, os_data, model, var_list)
call var_list%final ()
call process%setup_test_cores ()
allocate (phs_test_config_t :: phs_config_template)
call process%init_components (phs_config_template)
write (u, "(A)") "* Prepare a trivial beam setup"
write (u, "(A)")
sqrts = 1000
call process%setup_beams_sqrts (sqrts, i_core = 1)
call process%configure_phs ()
call process%setup_mci (dispatch_mci_empty)
write (u, "(A)") "* Complete process initialization and set cuts"
write (u, "(A)")
call process%setup_terms ()
call expr_factory%init (pt_scale%get_root_ptr ())
call process%set_scale (expr_factory)
call expr_factory%init (pt_fac_scale%get_root_ptr ())
call process%set_fac_scale (expr_factory)
call expr_factory%init (pt_ren_scale%get_root_ptr ())
call process%set_ren_scale (expr_factory)
call expr_factory%init (pt_weight%get_root_ptr ())
call process%set_weight (expr_factory)
call process%write (.false., u, show_expressions=.true.)
write (u, "(A)")
write (u, "(A)") "* Create a process instance and evaluate"
write (u, "(A)")
allocate (process_instance)
call process_instance%init (process)
call process_instance%choose_mci (1)
call process_instance%evaluate_sqme (1, [0.5_default, 0.125_default])
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process_instance%final ()
deallocate (process_instance)
call process%final ()
deallocate (process)
call parse_tree_final (pt_scale)
call parse_tree_final (pt_fac_scale)
call parse_tree_final (pt_ren_scale)
call parse_tree_final (pt_weight)
call syntax_pexpr_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_6"
end subroutine processes_6
@ %def processes_6
@
\subsubsection{Event expressions}
After generating an event, fill the [[subevt]] and evaluate expressions for
selection, reweighting, and analysis.
<<Expr tests: execute tests>>=
call test (events_3, "events_3", &
"expression evaluation", &
u, results)
<<Expr tests: test declarations>>=
public :: events_3
<<Expr tests: tests>>=
subroutine events_3 (u)
use processes_ut, only: prepare_test_process, cleanup_test_process
integer, intent(in) :: u
type(string_t) :: expr_text
type(ifile_t) :: ifile
type(stream_t) :: stream
type(parse_tree_t) :: pt_selection, pt_reweight, pt_analysis
type(eval_tree_factory_t) :: expr_factory
type(event_t), allocatable, target :: event
type(process_t), allocatable, target :: process
type(process_instance_t), allocatable, target :: process_instance
type(os_data_t) :: os_data
type(model_t), pointer :: model
type(var_list_t), target :: var_list
write (u, "(A)") "* Test output: events_3"
write (u, "(A)") "* Purpose: generate an event and evaluate expressions"
write (u, "(A)")
call syntax_pexpr_init ()
write (u, "(A)") "* Expression texts"
write (u, "(A)")
expr_text = "all Pt > 100 [s]"
write (u, "(A,A)") "selection = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_lexpr (pt_selection, stream, .true.)
call stream_final (stream)
expr_text = "1 + sqrts_hat / sqrts"
write (u, "(A,A)") "reweight = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_expr (pt_reweight, stream, .true.)
call stream_final (stream)
expr_text = "true"
write (u, "(A,A)") "analysis = ", char (expr_text)
call ifile_clear (ifile)
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call parse_tree_init_lexpr (pt_analysis, stream, .true.)
call stream_final (stream)
call ifile_final (ifile)
write (u, "(A)")
write (u, "(A)") "* Initialize test process event"
call os_data%init ()
call syntax_model_file_init ()
allocate (model)
call model%read (var_str ("Test.mdl"), os_data)
call var_list%init_snapshot (model%get_var_list_ptr ())
call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
call var_list%append_int (var_str ("seed"), 0)
allocate (process)
allocate (process_instance)
call prepare_test_process (process, process_instance, model, var_list)
call var_list%final ()
call process_instance%setup_event_data ()
write (u, "(A)")
write (u, "(A)") "* Initialize event object and set expressions"
allocate (event)
call event%basic_init ()
call expr_factory%init (pt_selection%get_root_ptr ())
call event%set_selection (expr_factory)
call expr_factory%init (pt_reweight%get_root_ptr ())
call event%set_reweight (expr_factory)
call expr_factory%init (pt_analysis%get_root_ptr ())
call event%set_analysis (expr_factory)
call event%connect (process_instance, process%get_model_ptr ())
call event%expr%var_list%append_real (var_str ("tolerance"), 0._default)
call event%setup_expressions ()
write (u, "(A)")
write (u, "(A)") "* Generate test process event"
call process_instance%generate_weighted_event (1)
write (u, "(A)")
write (u, "(A)") "* Fill event object and evaluate expressions"
write (u, "(A)")
call event%generate (1, [0.4_default, 0.4_default])
call event%set_index (42)
call event%evaluate_expressions ()
call event%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call event%final ()
deallocate (event)
call cleanup_test_process (process, process_instance)
deallocate (process_instance)
deallocate (process)
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: events_3"
end subroutine events_3
@ %def events_3
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Top Level}
The top level consists of
\begin{description}
\item[commands]
Defines generic command-list and command objects, and all specific
implementations. Each command type provides a specific
functionality. Together with the modules that provide expressions
and variables, this module defines the Sindarin language.
\item[whizard]
This module interprets streams of various kind in terms of the
command language. It also contains the unit-test feature. We also
define the externally visible procedures here, for the \whizard\ as
a library.
\item[main]
The driver for \whizard\ as a stand-alone program. Contains the
command-line interpreter.
\item[whizard\_c\_interface]
Alternative top-level procedures, for use in the context of a
C-compatible caller program.
\end{description}
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Commands}
This module defines the command language of the main input file.
<<[[commands.f90]]>>=
<<File header>>
module commands
<<Use kinds>>
<<Use strings>>
<<Use debug>>
use diagnostics
use lexers
use syntax_rules
use parser
use variables, only: var_list_t, V_NONE, V_LOG, V_INT, V_REAL, V_CMPLX, V_STR, V_PDG
use eval_trees
use polarizations
use rt_data
<<Standard module head>>
<<Commands: public>>
<<Commands: types>>
<<Commands: variables>>
<<Commands: parameters>>
<<Commands: interfaces>>
interface
<<Commands: sub interfaces>>
end interface
contains
<<Commands: main procedures>>
end module commands
@ %def commands
@
<<[[commands_sub.f90]]>>=
<<File header>>
submodule (commands) commands_s
<<Use mpi f08>>
use io_units
use string_utils, only: lower_case, split_string, str
use format_utils, only: write_indent
use format_defs, only: FMT_14, FMT_19
use constants, only: one
use physics_defs
use sorting
use sf_lhapdf, only: lhapdf_global_reset
use os_interface
use ifiles
use analysis
use pdg_arrays
use observables, only: var_list_check_observable
use observables, only: var_list_check_result_var
use models
use auto_components
use flavors
use particle_specifiers
use process_libraries
use process
use instances
use prclib_stacks
use slha_interface
use user_files
use eio_data
use process_configurations
use compilations, only: compile_library, compile_executable
use integrations, only: integrate_process
use restricted_subprocesses, only: get_libname_res
use restricted_subprocesses, only: spawn_resonant_subprocess_libraries
use event_streams
use radiation_generator
use simulations
implicit none
contains
<<Commands: procedures>>
end submodule commands_s
@ %def commands_s
@
\subsection{The command type}
The command type is a generic type that holds any command, compiled
for execution.
Each command may come with its own local environment. The command list that
determines this environment is allocated as [[options]], if necessary. (It
has to be allocated as a pointer because the type definition is recursive.) The
local environment is available as a pointer which either points to the global
environment, or is explicitly allocated and initialized.
<<Commands: types>>=
type, abstract :: command_t
type(parse_node_t), pointer :: pn => null ()
class(command_t), pointer :: next => null ()
type(parse_node_t), pointer :: pn_opt => null ()
type(command_list_t), pointer :: options => null ()
type(rt_data_t), pointer :: local => null ()
contains
<<Commands: command: TBP>>
end type command_t
@ %def command_t
@ Finalizer: If there is an option list, finalize the option list and
deallocate. If not, the local environment is just a pointer.
<<Commands: command: TBP>>=
procedure :: final => command_final
<<Commands: sub interfaces>>=
recursive module subroutine command_final (cmd)
class(command_t), intent(inout) :: cmd
end subroutine command_final
<<Commands: procedures>>=
recursive module subroutine command_final (cmd)
class(command_t), intent(inout) :: cmd
if (associated (cmd%options)) then
call cmd%options%final ()
deallocate (cmd%options)
call cmd%local%local_final ()
deallocate (cmd%local)
else
cmd%local => null ()
end if
end subroutine command_final
@ %def command_final
@ Allocate a command with the appropriate concrete type. Store the
parse node pointer in the command object, so we can reference to it
when compiling.
Gfortran 7/8/9 bug, has to remain in the main module:
<<Commands: main procedures>>=
subroutine dispatch_command (command, pn)
class(command_t), intent(inout), pointer :: command
type(parse_node_t), intent(in), target :: pn
select case (char (parse_node_get_rule_key (pn)))
case ("cmd_model")
allocate (cmd_model_t :: command)
case ("cmd_library")
allocate (cmd_library_t :: command)
case ("cmd_process")
allocate (cmd_process_t :: command)
case ("cmd_nlo")
allocate (cmd_nlo_t :: command)
case ("cmd_compile")
allocate (cmd_compile_t :: command)
case ("cmd_exec")
allocate (cmd_exec_t :: command)
case ("cmd_num", "cmd_complex", "cmd_real", "cmd_int", &
"cmd_log_decl", "cmd_log", "cmd_string", "cmd_string_decl", &
"cmd_alias", "cmd_result")
allocate (cmd_var_t :: command)
case ("cmd_slha")
allocate (cmd_slha_t :: command)
case ("cmd_show")
allocate (cmd_show_t :: command)
case ("cmd_clear")
allocate (cmd_clear_t :: command)
case ("cmd_expect")
allocate (cmd_expect_t :: command)
case ("cmd_beams")
allocate (cmd_beams_t :: command)
case ("cmd_beams_pol_density")
allocate (cmd_beams_pol_density_t :: command)
case ("cmd_beams_pol_fraction")
allocate (cmd_beams_pol_fraction_t :: command)
case ("cmd_beams_momentum")
allocate (cmd_beams_momentum_t :: command)
case ("cmd_beams_theta")
allocate (cmd_beams_theta_t :: command)
case ("cmd_beams_phi")
allocate (cmd_beams_phi_t :: command)
case ("cmd_cuts")
allocate (cmd_cuts_t :: command)
case ("cmd_scale")
allocate (cmd_scale_t :: command)
case ("cmd_fac_scale")
allocate (cmd_fac_scale_t :: command)
case ("cmd_ren_scale")
allocate (cmd_ren_scale_t :: command)
case ("cmd_weight")
allocate (cmd_weight_t :: command)
case ("cmd_selection")
allocate (cmd_selection_t :: command)
case ("cmd_reweight")
allocate (cmd_reweight_t :: command)
case ("cmd_iterations")
allocate (cmd_iterations_t :: command)
case ("cmd_integrate")
allocate (cmd_integrate_t :: command)
case ("cmd_observable")
allocate (cmd_observable_t :: command)
case ("cmd_histogram")
allocate (cmd_histogram_t :: command)
case ("cmd_plot")
allocate (cmd_plot_t :: command)
case ("cmd_graph")
allocate (cmd_graph_t :: command)
case ("cmd_record")
allocate (cmd_record_t :: command)
case ("cmd_analysis")
allocate (cmd_analysis_t :: command)
case ("cmd_alt_setup")
allocate (cmd_alt_setup_t :: command)
case ("cmd_unstable")
allocate (cmd_unstable_t :: command)
case ("cmd_stable")
allocate (cmd_stable_t :: command)
case ("cmd_polarized")
allocate (cmd_polarized_t :: command)
case ("cmd_unpolarized")
allocate (cmd_unpolarized_t :: command)
case ("cmd_sample_format")
allocate (cmd_sample_format_t :: command)
case ("cmd_simulate")
allocate (cmd_simulate_t :: command)
case ("cmd_rescan")
allocate (cmd_rescan_t :: command)
case ("cmd_write_analysis")
allocate (cmd_write_analysis_t :: command)
case ("cmd_compile_analysis")
allocate (cmd_compile_analysis_t :: command)
case ("cmd_open_out")
allocate (cmd_open_out_t :: command)
case ("cmd_close_out")
allocate (cmd_close_out_t :: command)
case ("cmd_printf")
allocate (cmd_printf_t :: command)
case ("cmd_scan")
allocate (cmd_scan_t :: command)
case ("cmd_if")
allocate (cmd_if_t :: command)
case ("cmd_include")
allocate (cmd_include_t :: command)
case ("cmd_export")
allocate (cmd_export_t :: command)
case ("cmd_quit")
allocate (cmd_quit_t :: command)
case default
print *, char (parse_node_get_rule_key (pn))
call msg_bug ("Command not implemented")
end select
command%pn => pn
end subroutine dispatch_command
@ %def dispatch_command
@ Output. We allow for indentation so we can display a command tree.
<<Commands: command: TBP>>=
procedure (command_write), deferred :: write
<<Commands: interfaces>>=
abstract interface
subroutine command_write (cmd, unit, indent)
import
class(command_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine command_write
end interface
@ %def command_write
@ Compile a command. The command type is already fixed, so this is a
deferred type-bound procedure.
<<Commands: command: TBP>>=
procedure (command_compile), deferred :: compile
<<Commands: interfaces>>=
abstract interface
subroutine command_compile (cmd, global)
import
class(command_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine command_compile
end interface
@ %def command_compile
@ Execute a command. This will use and/or modify the runtime data
set. If the [[quit]] flag is set, the caller should terminate command
execution.
<<Commands: command: TBP>>=
procedure (command_execute), deferred :: execute
<<Commands: interfaces>>=
abstract interface
subroutine command_execute (cmd, global)
import
class(command_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine command_execute
end interface
@ %def command_execute
@
\subsection{Options}
The [[options]] command list is allocated, initialized, and executed, if the
command is associated with an option text in curly braces. If present, a
separate local runtime data set [[local]] will be allocated and initialized;
otherwise, [[local]] becomes a pointer to the global dataset.
For output, we indent the options list.
<<Commands: command: TBP>>=
procedure :: write_options => command_write_options
<<Commands: sub interfaces>>=
recursive module subroutine command_write_options (cmd, unit, indent)
class(command_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine command_write_options
<<Commands: procedures>>=
recursive module subroutine command_write_options (cmd, unit, indent)
class(command_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: ind
ind = 1; if (present (indent)) ind = indent + 1
if (associated (cmd%options)) call cmd%options%write (unit, ind)
end subroutine command_write_options
@ %def command_write_options
@ Compile the options list, if any. This implies initialization of the local
environment. Should be done once the [[pn_opt]] node has been assigned (if
applicable), but before the actual command compilation.
<<Commands: command: TBP>>=
procedure :: compile_options => command_compile_options
<<Commands: sub interfaces>>=
recursive module subroutine command_compile_options (cmd, global)
class(command_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine command_compile_options
<<Commands: procedures>>=
recursive module subroutine command_compile_options (cmd, global)
class(command_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
if (associated (cmd%pn_opt)) then
allocate (cmd%local)
call cmd%local%local_init (global)
call global%copy_globals (cmd%local)
allocate (cmd%options)
call cmd%options%compile (cmd%pn_opt, cmd%local)
call global%restore_globals (cmd%local)
call cmd%local%deactivate ()
else
cmd%local => global
end if
end subroutine command_compile_options
@ %def command_compile_options
@ Execute options. First prepare the local environment, then execute the
command list.
<<Commands: command: TBP>>=
procedure :: execute_options => cmd_execute_options
<<Commands: sub interfaces>>=
recursive module subroutine cmd_execute_options (cmd, global)
class(command_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_execute_options
<<Commands: procedures>>=
recursive module subroutine cmd_execute_options (cmd, global)
class(command_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
if (associated (cmd%options)) then
call cmd%local%activate ()
call cmd%options%execute (cmd%local)
end if
end subroutine cmd_execute_options
@ %def cmd_execute_options
@ This must be called after the parent command has been executed, to undo
temporary modifications to the environment. Note that some modifications to
[[global]] can become permanent.
<<Commands: command: TBP>>=
procedure :: reset_options => cmd_reset_options
<<Commands: sub interfaces>>=
module subroutine cmd_reset_options (cmd, global)
class(command_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_reset_options
<<Commands: procedures>>=
module subroutine cmd_reset_options (cmd, global)
class(command_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
if (associated (cmd%options)) then
call cmd%local%deactivate (global)
end if
end subroutine cmd_reset_options
@ %def cmd_reset_options
@
\subsection{Specific command types}
\subsubsection{Model configuration}
The command declares a model, looks for the specified file and loads
it.
<<Commands: types>>=
type, extends (command_t) :: cmd_model_t
private
type(string_t) :: name
type(string_t) :: scheme
logical :: ufo_model = .false.
logical :: ufo_path_set = .false.
type(string_t) :: ufo_path
contains
<<Commands: cmd model: TBP>>
end type cmd_model_t
@ %def cmd_model_t
@ Output
<<Commands: cmd model: TBP>>=
procedure :: write => cmd_model_write
<<Commands: sub interfaces>>=
module subroutine cmd_model_write (cmd, unit, indent)
class(cmd_model_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_model_write
<<Commands: procedures>>=
module subroutine cmd_model_write (cmd, unit, indent)
class(cmd_model_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,1x,'""',A,'""')", advance="no") "model =", char (cmd%name)
if (cmd%ufo_model) then
if (cmd%ufo_path_set) then
write (u, "(1x,A,A,A)") "(ufo (", char (cmd%ufo_path), "))"
else
write (u, "(1x,A)") "(ufo)"
end if
else if (cmd%scheme /= "") then
write (u, "(1x,'(',A,')')") char (cmd%scheme)
else
write (u, *)
end if
end subroutine cmd_model_write
@ %def cmd_model_write
@ Compile. Get the model name and read the model from file, so it is
readily available when the command list is executed. If the model has a
scheme argument, take this into account.
Assign the model pointer in the [[global]] record, so it can be used for
(read-only) variable lookup while compiling further commands.
<<Commands: cmd model: TBP>>=
procedure :: compile => cmd_model_compile
<<Commands: sub interfaces>>=
module subroutine cmd_model_compile (cmd, global)
class(cmd_model_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_model_compile
<<Commands: procedures>>=
module subroutine cmd_model_compile (cmd, global)
class(cmd_model_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_name, pn_arg, pn_scheme
type(parse_node_t), pointer :: pn_ufo_arg, pn_path
type(model_t), pointer :: model
type(string_t) :: scheme
pn_name => cmd%pn%get_sub_ptr (3)
pn_arg => pn_name%get_next_ptr ()
if (associated (pn_arg)) then
pn_scheme => pn_arg%get_sub_ptr ()
else
pn_scheme => null ()
end if
cmd%name = pn_name%get_string ()
if (associated (pn_scheme)) then
select case (char (pn_scheme%get_rule_key ()))
case ("ufo_spec")
cmd%ufo_model = .true.
pn_ufo_arg => pn_scheme%get_sub_ptr (2)
if (associated (pn_ufo_arg)) then
pn_path => pn_ufo_arg%get_sub_ptr ()
cmd%ufo_path_set = .true.
cmd%ufo_path = pn_path%get_string ()
end if
case default
scheme = pn_scheme%get_string ()
select case (char (lower_case (scheme)))
case ("ufo"); cmd%ufo_model = .true.
case default; cmd%scheme = scheme
end select
end select
if (cmd%ufo_model) then
if (cmd%ufo_path_set) then
call preload_ufo_model (model, cmd%name, cmd%ufo_path)
else
call preload_ufo_model (model, cmd%name)
end if
else
call preload_model (model, cmd%name, cmd%scheme)
end if
else
cmd%scheme = ""
call preload_model (model, cmd%name)
end if
global%model => model
if (associated (global%model)) then
call global%model%link_var_list (global%var_list)
end if
contains
subroutine preload_model (model, name, scheme)
type(model_t), pointer, intent(out) :: model
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: scheme
model => null ()
if (associated (global%model)) then
if (global%model%matches (name, scheme)) then
model => global%model
end if
end if
if (.not. associated (model)) then
if (global%model_list%model_exists (name, scheme)) then
model => global%model_list%get_model_ptr (name, scheme)
else
call global%read_model (name, model, scheme)
end if
end if
end subroutine preload_model
subroutine preload_ufo_model (model, name, ufo_path)
type(model_t), pointer, intent(out) :: model
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: ufo_path
model => null ()
if (associated (global%model)) then
if (global%model%matches (name, ufo=.true., ufo_path=ufo_path)) then
model => global%model
end if
end if
if (.not. associated (model)) then
if (global%model_list%model_exists (name, &
ufo=.true., ufo_path=ufo_path)) then
model => global%model_list%get_model_ptr (name, &
ufo=.true., ufo_path=ufo_path)
else
call global%read_ufo_model (name, model, ufo_path=ufo_path)
end if
end if
end subroutine preload_ufo_model
end subroutine cmd_model_compile
@ %def cmd_model_compile
@ Execute: Insert a pointer into the global data record and reassign
the variable list.
<<Commands: cmd model: TBP>>=
procedure :: execute => cmd_model_execute
<<Commands: sub interfaces>>=
module subroutine cmd_model_execute (cmd, global)
class(cmd_model_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_model_execute
<<Commands: procedures>>=
module subroutine cmd_model_execute (cmd, global)
class(cmd_model_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
if (cmd%ufo_model) then
if (cmd%ufo_path_set) then
call global%select_model (cmd%name, ufo=.true., ufo_path=cmd%ufo_path)
else
call global%select_model (cmd%name, ufo=.true.)
end if
else if (cmd%scheme /= "") then
call global%select_model (cmd%name, cmd%scheme)
else
call global%select_model (cmd%name)
end if
if (.not. associated (global%model)) &
call msg_fatal ("Switching to model '" &
// char (cmd%name) // "': model not found")
end subroutine cmd_model_execute
@ %def cmd_model_execute
@
\subsubsection{Library configuration}
We configure a process library that should hold the subsequently
defined processes. If the referenced library exists already, just
make it the currently active one.
<<Commands: types>>=
type, extends (command_t) :: cmd_library_t
private
type(string_t) :: name
contains
<<Commands: cmd library: TBP>>
end type cmd_library_t
@ %def cmd_library_t
@ Output.
<<Commands: cmd library: TBP>>=
procedure :: write => cmd_library_write
<<Commands: sub interfaces>>=
module subroutine cmd_library_write (cmd, unit, indent)
class(cmd_library_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_library_write
<<Commands: procedures>>=
module subroutine cmd_library_write (cmd, unit, indent)
class(cmd_library_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit)
call write_indent (u, indent)
write (u, "(1x,A,1x,'""',A,'""')") "library =", char (cmd%name)
end subroutine cmd_library_write
@ %def cmd_library_write
@ Compile. Get the library name.
<<Commands: cmd library: TBP>>=
procedure :: compile => cmd_library_compile
<<Commands: sub interfaces>>=
module subroutine cmd_library_compile (cmd, global)
class(cmd_library_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_library_compile
<<Commands: procedures>>=
module subroutine cmd_library_compile (cmd, global)
class(cmd_library_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_name
pn_name => parse_node_get_sub_ptr (cmd%pn, 3)
cmd%name = parse_node_get_string (pn_name)
end subroutine cmd_library_compile
@ %def cmd_library_compile
@ Execute: Initialize a new library and push it on the library stack
(if it does not yet exist). Insert a pointer to the library into the
global data record. Then, try to load the library unless the
[[rebuild]] flag is set.
<<Commands: cmd library: TBP>>=
procedure :: execute => cmd_library_execute
<<Commands: sub interfaces>>=
module subroutine cmd_library_execute (cmd, global)
class(cmd_library_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_library_execute
<<Commands: procedures>>=
module subroutine cmd_library_execute (cmd, global)
class(cmd_library_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(prclib_entry_t), pointer :: lib_entry
type(process_library_t), pointer :: lib
logical :: rebuild_library
lib => global%prclib_stack%get_library_ptr (cmd%name)
rebuild_library = &
global%var_list%get_lval (var_str ("?rebuild_library"))
if (.not. (associated (lib))) then
allocate (lib_entry)
call lib_entry%init (cmd%name)
lib => lib_entry%process_library_t
call global%add_prclib (lib_entry)
else
call global%update_prclib (lib)
end if
if (associated (lib) .and. .not. rebuild_library) then
call lib%update_status (global%os_data)
end if
end subroutine cmd_library_execute
@ %def cmd_library_execute
@
\subsubsection{Process configuration}
We define a process-configuration command as a specific type. The
incoming and outgoing particles are given evaluation-trees which we
transform to PDG-code arrays. For transferring to \oMega, they are
reconverted to strings.
For the incoming particles, we store parse nodes individually. We do
not yet resolve the outgoing state, so we store just a single parse
node.
This also includes the choice of method for the corresponding process:
[[omega]] for \oMega\ matrix elements as Fortran code, [[ovm]] for
\oMega\ matrix elements as a bytecode virtual machine, [[test]] for
special processes, [[unit_test]] for internal test matrix elements
generated by \whizard, [[template]] and [[template_unity]] for test
matrix elements generated by \whizard\ as Fortran code similar to the
\oMega\ code. If the one-loop program (OLP) \gosam\ is linked, also
matrix elements from there (at leading and next-to-leading order) can
be generated via [[gosam]].
<<Commands: types>>=
type, extends (command_t) :: cmd_process_t
private
type(string_t) :: id
integer :: n_in = 0
type(parse_node_p), dimension(:), allocatable :: pn_pdg_in
type(parse_node_t), pointer :: pn_out => null ()
contains
<<Commands: cmd process: TBP>>
end type cmd_process_t
@ %def cmd_process_t
@ Output. The particle expressions are not resolved, so we just list the
number of incoming particles.
<<Commands: cmd process: TBP>>=
procedure :: write => cmd_process_write
<<Commands: sub interfaces>>=
module subroutine cmd_process_write (cmd, unit, indent)
class(cmd_process_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_process_write
<<Commands: procedures>>=
module subroutine cmd_process_write (cmd, unit, indent)
class(cmd_process_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,A,A,I0,A)") "process: ", char (cmd%id), " (", &
size (cmd%pn_pdg_in), " -> X)"
call cmd%write_options (u, indent)
end subroutine cmd_process_write
@ %def cmd_process_write
@ Compile. Find and assign the parse nodes.
<<Commands: cmd process: TBP>>=
procedure :: compile => cmd_process_compile
<<Commands: sub interfaces>>=
module subroutine cmd_process_compile (cmd, global)
class(cmd_process_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_process_compile
<<Commands: procedures>>=
module subroutine cmd_process_compile (cmd, global)
class(cmd_process_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_id, pn_in, pn_codes
integer :: i
pn_id => parse_node_get_sub_ptr (cmd%pn, 2)
pn_in => parse_node_get_next_ptr (pn_id, 2)
cmd%pn_out => parse_node_get_next_ptr (pn_in, 2)
cmd%pn_opt => parse_node_get_next_ptr (cmd%pn_out)
call cmd%compile_options (global)
cmd%id = parse_node_get_string (pn_id)
cmd%n_in = parse_node_get_n_sub (pn_in)
pn_codes => parse_node_get_sub_ptr (pn_in)
allocate (cmd%pn_pdg_in (cmd%n_in))
do i = 1, cmd%n_in
cmd%pn_pdg_in(i)%ptr => pn_codes
pn_codes => parse_node_get_next_ptr (pn_codes)
end do
end subroutine cmd_process_compile
@ %def cmd_process_compile
@ Command execution. Evaluate the subevents, transform PDG codes
into strings, and add the current process configuration to the
process library.
The initial state will be unique (one or two particles). For the final state,
we allow for expressions. The expressions will be expanded until we have a
sum of final states. Each distinct final state will get its own process
component.
To identify equivalent final states, we transform the final state into
an array of PDG codes, which we sort and compare. If a particle entry
is actually a PDG array, only the first entry in the array is used for
the comparison. The user should make sure that there is no overlap
between different particles or arrays which would make the expansion
ambiguous.
There are two possibilities that a process contains more than one
component: by an explicit component statement by the user for
inclusive processes, or by having one process at NLO level. The first
option is determined in the chunk [[scan components]], and
determines [[n_components]].
<<Commands: cmd process: TBP>>=
procedure :: execute => cmd_process_execute
<<Commands: sub interfaces>>=
module subroutine cmd_process_execute (cmd, global)
class(cmd_process_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_process_execute
<<Commands: procedures>>=
module subroutine cmd_process_execute (cmd, global)
class(cmd_process_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(pdg_array_t) :: pdg_in, pdg_out
type(pdg_array_t), dimension(:), allocatable :: pdg_out_tab
type(string_t), dimension(:), allocatable :: prt_in
type(string_t) :: prt_out, prt_out1
type(process_configuration_t) :: prc_config
type(prt_expr_t) :: prt_expr_out
type(prt_spec_t), dimension(:), allocatable :: prt_spec_in
type(prt_spec_t), dimension(:), allocatable :: prt_spec_out
type(var_list_t), pointer :: var_list
integer, dimension(:), allocatable :: ipdg
integer, dimension(:), allocatable :: i_term
integer, dimension(:), allocatable :: nlo_comp
integer :: i, j, n_in, n_out, n_terms, n_components
logical :: nlo_fixed_order
logical :: qcd_corr, qed_corr
type(string_t), dimension(:), allocatable :: prt_in_nlo, prt_out_nlo
type(radiation_generator_t) :: radiation_generator
type(pdg_list_t) :: pl_in, pl_out, pl_excluded_gauge_splittings
type(string_t) :: method, born_me_method, loop_me_method, &
correlation_me_method, real_tree_me_method, dglap_me_method
integer, dimension(:), allocatable :: i_list
logical :: use_real_finite
logical :: gks_active
logical :: initial_state_colored
logical :: neg_sf
integer :: comp_mult
integer :: gks_multiplicity
integer :: n_components_init
integer :: alpha_power, alphas_power
logical :: requires_soft_mismatch, requires_dglap_remnants
type(string_t) :: nlo_correction_type
type(pdg_array_t), dimension(:), allocatable :: pdg
if (debug_on) call msg_debug (D_CORE, "cmd_process_execute")
var_list => cmd%local%get_var_list_ptr ()
n_in = size (cmd%pn_pdg_in)
allocate (prt_in (n_in), prt_spec_in (n_in))
do i = 1, n_in
pdg_in = &
eval_pdg_array (cmd%pn_pdg_in(i)%ptr, var_list)
prt_in(i) = make_flavor_string (pdg_in, cmd%local%model)
prt_spec_in(i) = new_prt_spec (prt_in(i))
end do
call compile_prt_expr &
(prt_expr_out, cmd%pn_out, var_list, cmd%local%model)
call prt_expr_out%expand ()
<<Commands: cmd process execute: scan components>>
allocate (nlo_comp (n_components))
nlo_fixed_order = cmd%local%nlo_fixed_order
gks_multiplicity = var_list%get_ival (var_str ("gks_multiplicity"))
gks_active = gks_multiplicity > 2
neg_sf = .false.
select case (char (var_list%get_sval (var_str ("$negative_sf"))))
case ("default")
neg_sf = nlo_fixed_order
case ("negative")
neg_sf = .true.
case ("positive")
neg_sf = .false.
case default
call msg_fatal ("Negative PDF handling can only be " // &
"default, negative or positive.")
end select
<<Commands: cmd process execute: check for nlo corrections>>
method = var_list%get_sval (var_str ("$method"))
born_me_method = var_list%get_sval (var_str ("$born_me_method"))
if (born_me_method == var_str ("")) born_me_method = method
select case (char (var_list%get_sval (var_str ("$real_partition_mode"))))
case ("default", "off", "singular")
use_real_finite = .false.
case ("all", "on", "finite")
use_real_finite = .true.
case default
call msg_fatal ("The real partition mode can only be " // &
"default, off, all, on, singular or finite.")
end select
if (nlo_fixed_order) then
real_tree_me_method = &
var_list%get_sval (var_str ("$real_tree_me_method"))
if (real_tree_me_method == var_str ("")) &
real_tree_me_method = method
loop_me_method = var_list%get_sval (var_str ("$loop_me_method"))
if (loop_me_method == var_str ("")) &
loop_me_method = method
correlation_me_method = &
var_list%get_sval (var_str ("$correlation_me_method"))
if (correlation_me_method == var_str ("")) &
correlation_me_method = method
dglap_me_method = var_list%get_sval (var_str ("$dglap_me_method"))
if (dglap_me_method == var_str ("")) &
dglap_me_method = method
call check_nlo_options (cmd%local)
end if
call determine_needed_components ()
call prc_config%init (cmd%id, n_in, n_components_init, &
cmd%local%model, cmd%local%var_list, &
nlo_process = nlo_fixed_order, &
negative_sf = neg_sf)
alpha_power = var_list%get_ival (var_str ("alpha_power"))
alphas_power = var_list%get_ival (var_str ("alphas_power"))
call prc_config%set_coupling_powers (alpha_power, alphas_power)
call setup_components ()
call prc_config%record (cmd%local)
contains
<<Commands: cmd process execute procedures>>
end subroutine cmd_process_execute
@ %def cmd_process_execute
@
<<Commands: cmd process execute procedures>>=
elemental function is_threshold (method)
logical :: is_threshold
type(string_t), intent(in) :: method
is_threshold = method == var_str ("threshold")
end function is_threshold
subroutine check_threshold_consistency ()
if (nlo_fixed_order .and. is_threshold (born_me_method)) then
if (.not. (is_threshold (real_tree_me_method) .and. is_threshold (loop_me_method) &
.and. is_threshold (correlation_me_method))) then
print *, 'born: ', char (born_me_method)
print *, 'real: ', char (real_tree_me_method)
print *, 'loop: ', char (loop_me_method)
print *, 'correlation: ', char (correlation_me_method)
call msg_fatal ("Inconsistent methods: All components need to be threshold")
end if
end if
end subroutine check_threshold_consistency
@ %def check_threshold_consistency
<<Commands: cmd process execute: check for nlo corrections>>=
if (nlo_fixed_order .or. gks_active) then
nlo_correction_type = &
var_list%get_sval (var_str ('$nlo_correction_type'))
select case (char (nlo_correction_type))
case ("QCD")
qcd_corr = .true.; qed_corr = .false.
case ("EW")
qcd_corr = .false.; qed_corr = .true.
case ("Full")
qcd_corr =.true.; qed_corr = .true.
case default
call msg_fatal ("Invalid NLO correction type. " // &
"Valid inputs are: QCD, EW, Full (default: QCD)")
end select
call check_for_excluded_gauge_boson_splitting_partners ()
call setup_radiation_generator ()
end if
if (nlo_fixed_order) then
call radiation_generator%find_splittings ()
if (debug2_active (D_CORE)) then
print *, ''
print *, 'Found (pdg) splittings: '
do i = 1, radiation_generator%if_table%get_length ()
call radiation_generator%if_table%get_pdg_out (i, pdg)
call pdg_array_write_set (pdg)
print *, '----------------'
end do
end if
nlo_fixed_order = radiation_generator%contains_emissions ()
if (.not. nlo_fixed_order) call msg_warning &
(arr = [var_str ("No NLO corrections found for process ") // &
cmd%id // var_str("."), var_str ("Proceed with usual " // &
"leading-order integration and simulation")])
end if
@ %def check_for_nlo_corrections
@
<<Commands: cmd process execute procedures>>=
subroutine check_for_excluded_gauge_boson_splitting_partners ()
type(string_t) :: str_excluded_partners
type(string_t), dimension(:), allocatable :: excluded_partners
type(pdg_list_t) :: pl_tmp, pl_anti
integer :: i, n_anti
str_excluded_partners = var_list%get_sval &
(var_str ("$exclude_gauge_splittings"))
if (str_excluded_partners == "") then
return
else
call split_string (str_excluded_partners, &
var_str (":"), excluded_partners)
call pl_tmp%init (size (excluded_partners))
do i = 1, size (excluded_partners)
call pl_tmp%set (i, &
cmd%local%model%get_pdg (excluded_partners(i), .true.))
end do
call pl_tmp%create_antiparticles (pl_anti, n_anti)
call pl_excluded_gauge_splittings%init (pl_tmp%get_size () + n_anti)
do i = 1, pl_tmp%get_size ()
call pl_excluded_gauge_splittings%set (i, pl_tmp%get(i))
end do
do i = 1, n_anti
j = i + pl_tmp%get_size ()
call pl_excluded_gauge_splittings%set (j, pl_anti%get(i))
end do
end if
end subroutine check_for_excluded_gauge_boson_splitting_partners
@ %def check_for_excluded_gauge_boson_splitting_partners
@
<<Commands: cmd process execute procedures>>=
subroutine determine_needed_components ()
type(string_t) :: fks_method
comp_mult = 1
if (nlo_fixed_order) then
fks_method = var_list%get_sval (var_str ('$fks_mapping_type'))
call check_threshold_consistency ()
requires_soft_mismatch = fks_method == var_str ('resonances')
comp_mult = needed_extra_components (requires_dglap_remnants, &
use_real_finite, requires_soft_mismatch)
allocate (i_list (comp_mult))
else if (gks_active) then
call radiation_generator%generate_multiple &
(gks_multiplicity, cmd%local%model)
comp_mult = radiation_generator%get_n_gks_states () + 1
end if
n_components_init = n_components * comp_mult
end subroutine determine_needed_components
@ %def determine_needed_components
@
<<Commands: cmd process execute procedures>>=
subroutine setup_radiation_generator ()
call split_prt (prt_spec_in, n_in, pl_in)
call split_prt (prt_spec_out, n_out, pl_out)
call radiation_generator%init (pl_in, pl_out, &
pl_excluded_gauge_splittings, qcd = qcd_corr, qed = qed_corr)
call radiation_generator%set_n (n_in, n_out, 0)
initial_state_colored = pdg_in%has_colored_particles ()
if ((n_in == 2 .and. initial_state_colored) .or. qed_corr) then
requires_dglap_remnants = n_in == 2 .and. initial_state_colored
call radiation_generator%set_initial_state_emissions ()
else
requires_dglap_remnants = .false.
end if
call radiation_generator%set_constraints (.false., .false., .true., .true.)
call radiation_generator%setup_if_table (cmd%local%model)
end subroutine setup_radiation_generator
@ %def setup_radiation_generator
@
<<Commands: cmd process execute: scan components>>=
n_terms = prt_expr_out%get_n_terms ()
allocate (pdg_out_tab (n_terms))
allocate (i_term (n_terms), source = 0)
n_components = 0
SCAN: do i = 1, n_terms
if (allocated (ipdg)) deallocate (ipdg)
call prt_expr_out%term_to_array (prt_spec_out, i)
n_out = size (prt_spec_out)
allocate (ipdg (n_out))
do j = 1, n_out
prt_out = prt_spec_out(j)%to_string ()
call split (prt_out, prt_out1, ":")
ipdg(j) = cmd%local%model%get_pdg (prt_out1)
end do
pdg_out = sort (ipdg)
do j = 1, n_components
if (pdg_out == pdg_out_tab(j)) cycle SCAN
end do
n_components = n_components + 1
i_term(n_components) = i
pdg_out_tab(n_components) = pdg_out
end do SCAN
@
<<Commands: cmd process execute procedures>>=
subroutine split_prt (prt, n_out, pl)
type(prt_spec_t), intent(in), dimension(:), allocatable :: prt
integer, intent(in) :: n_out
type(pdg_list_t), intent(out) :: pl
type(pdg_array_t) :: pdg
type(string_t) :: prt_string, prt_tmp
integer, parameter :: max_particle_number = 25
integer, dimension(max_particle_number) :: i_particle
integer :: i, j, n
i_particle = 0
call pl%init (n_out)
do i = 1, n_out
n = 1
prt_string = prt(i)%to_string ()
do
call split (prt_string, prt_tmp, ":")
if (prt_tmp /= "") then
i_particle(n) = cmd%local%model%get_pdg (prt_tmp)
n = n + 1
else
exit
end if
end do
call pdg%init (n - 1)
do j = 1, n - 1
call pdg%set (j, i_particle(j))
end do
call pl%set (i, pdg)
call pdg%delete ()
end do
end subroutine split_prt
@ %def split_prt
@
<<Commands: cmd process execute procedures>>=
subroutine setup_components()
integer :: k, i_comp, add_index
i_comp = 0
add_index = 0
if (debug_on) call msg_debug (D_CORE, "setup_components")
do i = 1, n_components
call prt_expr_out%term_to_array (prt_spec_out, i_term(i))
if (nlo_fixed_order) then
associate (selected_nlo_parts => cmd%local%selected_nlo_parts)
if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
i_comp + 1)
call prc_config%setup_component (i_comp + 1, &
prt_spec_in, prt_spec_out, &
cmd%local%model, var_list, BORN, &
can_be_integrated = selected_nlo_parts (BORN))
call radiation_generator%generate_real_particle_strings &
(prt_in_nlo, prt_out_nlo)
if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
i_comp + 2)
call prc_config%setup_component (i_comp + 2, &
new_prt_spec (prt_in_nlo), new_prt_spec (prt_out_nlo), &
cmd%local%model, var_list, NLO_REAL, &
can_be_integrated = selected_nlo_parts (NLO_REAL))
if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
i_comp + 3)
call prc_config%setup_component (i_comp + 3, &
prt_spec_in, prt_spec_out, &
cmd%local%model, var_list, NLO_VIRTUAL, &
can_be_integrated = selected_nlo_parts (NLO_VIRTUAL))
if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
i_comp + 4)
call prc_config%setup_component (i_comp + 4, &
prt_spec_in, prt_spec_out, &
cmd%local%model, var_list, NLO_SUBTRACTION, &
can_be_integrated = selected_nlo_parts (NLO_SUBTRACTION))
do k = 1, 4
i_list(k) = i_comp + k
end do
if (requires_dglap_remnants) then
if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
i_comp + 5)
call prc_config%setup_component (i_comp + 5, &
prt_spec_in, prt_spec_out, &
cmd%local%model, var_list, NLO_DGLAP, &
can_be_integrated = selected_nlo_parts (NLO_DGLAP))
i_list(5) = i_comp + 5
add_index = add_index + 1
end if
if (use_real_finite) then
if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
i_comp + 5 + add_index)
call prc_config%setup_component (i_comp + 5 + add_index, &
new_prt_spec (prt_in_nlo), new_prt_spec (prt_out_nlo), &
cmd%local%model, var_list, NLO_REAL, &
can_be_integrated = selected_nlo_parts (NLO_REAL))
i_list(5 + add_index) = i_comp + 5 + add_index
add_index = add_index + 1
end if
if (requires_soft_mismatch) then
if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
i_comp + 5 + add_index)
call prc_config%setup_component (i_comp + 5 + add_index, &
prt_spec_in, prt_spec_out, &
cmd%local%model, var_list, NLO_MISMATCH, &
can_be_integrated = selected_nlo_parts (NLO_MISMATCH))
i_list(5 + add_index) = i_comp + 5 + add_index
end if
call prc_config%set_component_associations (i_list, &
requires_dglap_remnants, use_real_finite, &
requires_soft_mismatch)
end associate
else if (gks_active) then
call prc_config%setup_component (i_comp + 1, prt_spec_in, &
prt_spec_out, cmd%local%model, var_list, BORN, &
can_be_integrated = .true.)
call radiation_generator%reset_queue ()
do j = 1, comp_mult
prt_out_nlo = radiation_generator%get_next_state ()
call prc_config%setup_component (i_comp + 1 + j, &
new_prt_spec (prt_in), new_prt_spec (prt_out_nlo), &
cmd%local%model, var_list, GKS, can_be_integrated = .false.)
end do
else
call prc_config%setup_component (i, &
prt_spec_in, prt_spec_out, &
cmd%local%model, var_list, can_be_integrated = .true.)
end if
i_comp = i_comp + comp_mult
end do
end subroutine setup_components
@
@ These three functions should be bundled with the logicals they depend
on into an object (the pcm?).
<<Commands: procedures>>=
subroutine check_nlo_options (local)
type(rt_data_t), intent(in) :: local
type(var_list_t), pointer :: var_list => null ()
real :: mult_real, mult_virt, mult_dglap
logical :: combined, powheg
logical :: case_lo_but_any_other
logical :: fixed_order_nlo_events
logical :: real_finite_only
var_list => local%get_var_list_ptr ()
combined = var_list%get_lval (var_str ('?combined_nlo_integration'))
powheg = var_list%get_lval (var_str ('?powheg_matching'))
if (powheg .and. .not. combined) then
call msg_fatal ("POWHEG matching requires the 'combined_nlo_integration' &
&-option to be set to true.")
end if
fixed_order_nlo_events = &
var_list%get_lval (var_str ('?fixed_order_nlo_events'))
if (fixed_order_nlo_events .and. .not. combined .and. &
count (local%selected_nlo_parts) > 1) &
call msg_fatal ("Option mismatch: Fixed order NLO events of multiple ", &
[var_str ("components are requested, but ?combined_nlo_integration "), &
var_str ("is false. You can either switch to the combined NLO "), &
var_str ("integration mode for the full process or choose one "), &
var_str ("individual NLO component to generate events with.")])
real_finite_only = local%var_list%get_sval (var_str ("$real_partition_mode")) == "finite"
associate (nlo_parts => local%selected_nlo_parts)
! TODO (PS-2020-03-26): This technically leaves the possibility to skip this
! message by deactivating the dglap component for a proton collider process.
! To circumvent this, the selected_nlo_parts should be refactored.
if (combined .and. .not. (nlo_parts(BORN) &
.and. nlo_parts(NLO_VIRTUAL) .and. nlo_parts(NLO_REAL))) then
call msg_fatal ("A combined integration of anything else than", &
[var_str ("all NLO components together is not supported.")])
end if
if (real_finite_only .and. combined) then
call msg_fatal ("You cannot do a combined integration without", &
[var_str ("the real singular component.")])
end if
if (real_finite_only .and. count(nlo_parts([BORN,NLO_VIRTUAL,NLO_DGLAP])) > 1) then
call msg_fatal ("You cannot do a full NLO integration without", &
[var_str ("the real singular component.")])
end if
end associate
mult_real = local%var_list%get_rval (var_str ("mult_call_real"))
mult_virt = local%var_list%get_rval (var_str ("mult_call_virt"))
mult_dglap = local%var_list%get_rval (var_str ("mult_call_dglap"))
if (combined .and. (mult_real /= one .or. mult_virt /= one .or. mult_dglap /= one)) then
call msg_warning ("mult_call_real, mult_call_virt and mult_call_dglap", &
[var_str (" will be ignored because of ?combined_nlo_integration = true. ")])
end if
end subroutine check_nlo_options
@ %def check_nlo_options
@ There are four components for a general NLO process, namely Born,
real, virtual and subtraction. There will be additional components for
DGLAP remnant, in case real contributions are split into singular and
finite pieces, and for resonance-aware FKS subtraction for the needed
soft mismatch component.
<<Commands: procedures>>=
pure function needed_extra_components (requires_dglap_remnant, &
use_real_finite, requires_soft_mismatch) result (n)
integer :: n
logical, intent(in) :: requires_dglap_remnant, &
use_real_finite, requires_soft_mismatch
n = 4
if (requires_dglap_remnant) n = n + 1
if (use_real_finite) n = n + 1
if (requires_soft_mismatch) n = n + 1
end function needed_extra_components
@ %def needed_extra_components
@ This is a method of the eval tree, but cannot be coded inside the
[[expressions]] module since it uses the [[model]] and [[flv]] types
which are not available there.
<<Commands: procedures>>=
function make_flavor_string (aval, model) result (prt)
type(string_t) :: prt
type(pdg_array_t), intent(in) :: aval
type(model_t), intent(in), target :: model
integer, dimension(:), allocatable :: pdg
type(flavor_t), dimension(:), allocatable :: flv
integer :: i
pdg = aval
allocate (flv (size (pdg)))
call flv%init (pdg, model)
if (size (pdg) /= 0) then
prt = flv(1)%get_name ()
do i = 2, size (flv)
prt = prt // ":" // flv(i)%get_name ()
end do
else
prt = "?"
end if
end function make_flavor_string
@ %def make_flavor_string
@ Create a pdg array from a particle-specification array
<<Commands: procedures>>=
function make_pdg_array (prt, model) result (pdg_array)
type(prt_spec_t), intent(in), dimension(:) :: prt
type(model_t), intent(in) :: model
integer, dimension(:), allocatable :: aval
type(pdg_array_t) :: pdg_array
type(flavor_t) :: flv
integer :: k
allocate (aval (size (prt)))
do k = 1, size (prt)
call flv%init (prt(k)%to_string (), model)
aval (k) = flv%get_pdg ()
end do
pdg_array = aval
end function make_pdg_array
@ %def make_pdg_array
@ Compile a (possible nested) expression, to obtain a
particle-specifier expression which we can process further.
<<Commands: procedures>>=
recursive subroutine compile_prt_expr (prt_expr, pn, var_list, model)
type(prt_expr_t), intent(out) :: prt_expr
type(parse_node_t), intent(in), target :: pn
type(var_list_t), intent(in), target :: var_list
type(model_t), intent(in), target :: model
type(parse_node_t), pointer :: pn_entry, pn_term, pn_addition
type(pdg_array_t) :: pdg
type(string_t) :: prt_string
integer :: n_entry, n_term, i
select case (char (parse_node_get_rule_key (pn)))
case ("prt_state_list")
n_entry = parse_node_get_n_sub (pn)
pn_entry => parse_node_get_sub_ptr (pn)
if (n_entry == 1) then
call compile_prt_expr (prt_expr, pn_entry, var_list, model)
else
call prt_expr%init_list (n_entry)
select type (x => prt_expr%x)
type is (prt_spec_list_t)
do i = 1, n_entry
call compile_prt_expr (x%expr(i), pn_entry, var_list, model)
pn_entry => parse_node_get_next_ptr (pn_entry)
end do
end select
end if
case ("prt_state_sum")
n_term = parse_node_get_n_sub (pn)
pn_term => parse_node_get_sub_ptr (pn)
pn_addition => pn_term
if (n_term == 1) then
call compile_prt_expr (prt_expr, pn_term, var_list, model)
else
call prt_expr%init_sum (n_term)
select type (x => prt_expr%x)
type is (prt_spec_sum_t)
do i = 1, n_term
call compile_prt_expr (x%expr(i), pn_term, var_list, model)
pn_addition => parse_node_get_next_ptr (pn_addition)
if (associated (pn_addition)) &
pn_term => parse_node_get_sub_ptr (pn_addition, 2)
end do
end select
end if
case ("cexpr")
pdg = eval_pdg_array (pn, var_list)
prt_string = make_flavor_string (pdg, model)
call prt_expr%init_spec (new_prt_spec (prt_string))
case default
call parse_node_write_rec (pn)
call msg_bug ("compile prt expr: impossible syntax rule")
end select
end subroutine compile_prt_expr
@ %def compile_prt_expr
@
\subsubsection{Initiating a NLO calculation}
<<Commands: types>>=
type, extends (command_t) :: cmd_nlo_t
private
integer, dimension(:), allocatable :: nlo_component
contains
<<Commands: cmd nlo: TBP>>
end type cmd_nlo_t
@ %def cmd_nlo_t
@ Incomplete.
<<Commands: cmd nlo: TBP>>=
procedure :: write => cmd_nlo_write
<<Commands: sub interfaces>>=
module subroutine cmd_nlo_write (cmd, unit, indent)
class(cmd_nlo_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_nlo_write
<<Commands: procedures>>=
module subroutine cmd_nlo_write (cmd, unit, indent)
class(cmd_nlo_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_nlo_write
@ %def cmd_nlo_write
@ As it is, the NLO calculation is switched on by putting {nlo} behind
the process definition. This should be made nicer in the future.
<<Commands: cmd nlo: TBP>>=
procedure :: compile => cmd_nlo_compile
<<Commands: sub interfaces>>=
module subroutine cmd_nlo_compile (cmd, global)
class(cmd_nlo_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_nlo_compile
<<Commands: procedures>>=
module subroutine cmd_nlo_compile (cmd, global)
class(cmd_nlo_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_arg, pn_comp
integer :: i, n_comp
pn_arg => parse_node_get_sub_ptr (cmd%pn, 3)
if (associated (pn_arg)) then
n_comp = parse_node_get_n_sub (pn_arg)
allocate (cmd%nlo_component (n_comp))
pn_comp => parse_node_get_sub_ptr (pn_arg)
i = 0
do while (associated (pn_comp))
i = i + 1
cmd%nlo_component(i) = component_status &
(parse_node_get_rule_key (pn_comp))
pn_comp => parse_node_get_next_ptr (pn_comp)
end do
else
allocate (cmd%nlo_component (0))
end if
end subroutine cmd_nlo_compile
@ %def cmd_nlo_compile
@ % TODO (PS-2020-03-26): This routine still needs to be adopted
% to cope with more than 5 components.
<<Commands: cmd nlo: TBP>>=
procedure :: execute => cmd_nlo_execute
<<Commands: sub interfaces>>=
module subroutine cmd_nlo_execute (cmd, global)
class(cmd_nlo_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_nlo_execute
<<Commands: procedures>>=
module subroutine cmd_nlo_execute (cmd, global)
class(cmd_nlo_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(string_t) :: string
integer :: n, i, j
logical, dimension(0:5) :: selected_nlo_parts
if (debug_on) call msg_debug (D_CORE, "cmd_nlo_execute")
selected_nlo_parts = .false.
if (allocated (cmd%nlo_component)) then
n = size (cmd%nlo_component)
else
n = 0
end if
do i = 1, n
select case (cmd%nlo_component (i))
case (BORN, NLO_VIRTUAL, NLO_MISMATCH, NLO_DGLAP, NLO_REAL)
selected_nlo_parts(cmd%nlo_component (i)) = .true.
case (NLO_FULL)
selected_nlo_parts = .true.
selected_nlo_parts (NLO_SUBTRACTION) = .false.
case default
string = var_str ("")
do j = BORN, NLO_DGLAP
string = string // component_status (j) // ", "
end do
string = string // component_status (NLO_FULL)
call msg_fatal ("Invalid NLO mode. Valid modes are: " // &
char (string))
end select
end do
global%nlo_fixed_order = any (selected_nlo_parts)
global%selected_nlo_parts = selected_nlo_parts
allocate (global%nlo_component (size (cmd%nlo_component)))
global%nlo_component = cmd%nlo_component
end subroutine cmd_nlo_execute
@ %def cmd_nlo_execute
@
\subsubsection{Process compilation}
<<Commands: types>>=
type, extends (command_t) :: cmd_compile_t
private
type(string_t), dimension(:), allocatable :: libname
logical :: make_executable = .false.
type(string_t) :: exec_name
contains
<<Commands: cmd compile: TBP>>
end type cmd_compile_t
@ %def cmd_compile_t
@ Output: list all libraries to be compiled.
<<Commands: cmd compile: TBP>>=
procedure :: write => cmd_compile_write
<<Commands: sub interfaces>>=
module subroutine cmd_compile_write (cmd, unit, indent)
class(cmd_compile_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_compile_write
<<Commands: procedures>>=
module subroutine cmd_compile_write (cmd, unit, indent)
class(cmd_compile_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)", advance="no") "compile ("
if (allocated (cmd%libname)) then
do i = 1, size (cmd%libname)
if (i > 1) write (u, "(A,1x)", advance="no") ","
write (u, "('""',A,'""')", advance="no") char (cmd%libname(i))
end do
end if
write (u, "(A)") ")"
end subroutine cmd_compile_write
@ %def cmd_compile_write
@ Compile the libraries specified in the argument. If the argument is
empty, compile all libraries which can be found in the process library stack.
<<Commands: cmd compile: TBP>>=
procedure :: compile => cmd_compile_compile
<<Commands: sub interfaces>>=
module subroutine cmd_compile_compile (cmd, global)
class(cmd_compile_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_compile_compile
<<Commands: procedures>>=
module subroutine cmd_compile_compile (cmd, global)
class(cmd_compile_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_cmd, pn_clause, pn_arg, pn_lib
type(parse_node_t), pointer :: pn_exec_name_spec, pn_exec_name
integer :: n_lib, i
pn_cmd => parse_node_get_sub_ptr (cmd%pn)
pn_clause => parse_node_get_sub_ptr (pn_cmd)
pn_exec_name_spec => parse_node_get_sub_ptr (pn_clause, 2)
if (associated (pn_exec_name_spec)) then
pn_exec_name => parse_node_get_sub_ptr (pn_exec_name_spec, 2)
else
pn_exec_name => null ()
end if
pn_arg => parse_node_get_next_ptr (pn_clause)
cmd%pn_opt => parse_node_get_next_ptr (pn_cmd)
call cmd%compile_options (global)
if (associated (pn_arg)) then
n_lib = parse_node_get_n_sub (pn_arg)
else
n_lib = 0
end if
if (n_lib > 0) then
allocate (cmd%libname (n_lib))
pn_lib => parse_node_get_sub_ptr (pn_arg)
do i = 1, n_lib
cmd%libname(i) = parse_node_get_string (pn_lib)
pn_lib => parse_node_get_next_ptr (pn_lib)
end do
end if
if (associated (pn_exec_name)) then
cmd%make_executable = .true.
cmd%exec_name = parse_node_get_string (pn_exec_name)
end if
end subroutine cmd_compile_compile
@ %def cmd_compile_compile
@ Command execution. Generate code, write driver, compile and link.
Do this for all libraries in the list.
If no library names have been given and stored while compiling this
command, we collect all libraries from the current stack and compile
those.
As a bonus, a compiled library may be able to spawn new process
libraries. For instance, a processes may ask for a set of resonant
subprocesses which go into their own library, but this can be
determined only after the process is available as a compiled object.
Therefore, the compilation loop is implemented as a recursive internal
subroutine.
We can compile static libraries (which actually just loads them). However, we
can't incorporate in a generated executable.
<<Commands: cmd compile: TBP>>=
procedure :: execute => cmd_compile_execute
<<Commands: sub interfaces>>=
module subroutine cmd_compile_execute (cmd, global)
class(cmd_compile_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_compile_execute
<<Commands: procedures>>=
module subroutine cmd_compile_execute (cmd, global)
class(cmd_compile_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(string_t), dimension(:), allocatable :: libname, libname_static
integer :: i, n_lib
<<Commands: cmd compile execute: extra variables>>
<<Commands: cmd compile execute: extra init>>
if (allocated (cmd%libname)) then
allocate (libname (size (cmd%libname)))
libname = cmd%libname
else
call cmd%local%prclib_stack%get_names (libname)
end if
n_lib = size (libname)
if (cmd%make_executable) then
call get_prclib_static (libname_static)
do i = 1, n_lib
if (any (libname_static == libname(i))) then
call msg_fatal ("Compile: can't include static library '" &
// char (libname(i)) // "'")
end if
end do
call compile_executable (cmd%exec_name, libname, cmd%local)
else
call compile_libraries (libname)
call global%update_prclib &
(global%prclib_stack%get_library_ptr (libname(n_lib)))
end if
<<Commands: cmd compile execute: extra end init>>
contains
recursive subroutine compile_libraries (libname)
type(string_t), dimension(:), intent(in) :: libname
integer :: i
type(string_t), dimension(:), allocatable :: libname_extra
type(process_library_t), pointer :: lib_saved
do i = 1, size (libname)
call compile_library (libname(i), cmd%local)
lib_saved => global%prclib
call spawn_extra_libraries &
(libname(i), cmd%local, global, libname_extra)
call compile_libraries (libname_extra)
call global%update_prclib (lib_saved)
end do
end subroutine compile_libraries
end subroutine cmd_compile_execute
@ %def cmd_compile_execute
<<Commands: cmd compile execute: extra variables>>=
<<Commands: cmd compile execute: extra init>>=
<<Commands: cmd compile execute: extra end init>>=
@ The parallelization leads to undefined behavior while writing simultaneously to one file.
The master worker has to initialize single-handed the corresponding library files.
The slave worker will wait with a blocking [[MPI_BCAST]] until they receive a logical flag.
<<MPI: Commands: cmd compile execute: extra variables>>=
logical :: compile_init
integer :: rank, n_size
<<MPI: Commands: cmd compile execute: extra init>>=
if (debug_on) call msg_debug (D_MPI, "cmd_compile_execute")
compile_init = .false.
call mpi_get_comm_id (n_size, rank)
if (debug_on) call msg_debug (D_MPI, "n_size", rank)
if (debug_on) call msg_debug (D_MPI, "rank", rank)
if (rank /= 0) then
if (debug_on) call msg_debug (D_MPI, "wait for master")
call MPI_bcast (compile_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD)
else
compile_init = .true.
end if
if (compile_init) then
<<MPI: Commands: cmd compile execute: extra end init>>=
if (rank == 0) then
if (debug_on) call msg_debug (D_MPI, "load slaves")
call MPI_bcast (compile_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD)
end if
end if
call MPI_barrier (MPI_COMM_WORLD)
@ %def cmd_compile_execute_mpi
@
This is the interface to the external procedure which returns the
names of all static libraries which are part of the executable. (The
default is none.) The routine must allocate the array.
<<Commands: public>>=
public :: get_prclib_static
<<Commands: interfaces>>=
interface
subroutine get_prclib_static (libname)
import
type(string_t), dimension(:), intent(inout), allocatable :: libname
end subroutine get_prclib_static
end interface
@ %def get_prclib_static
@
Spawn extra libraries. We can ask the processes within a compiled
library, which we have available at this point, whether they need additional
processes which should go into their own libraries.
The current implementation only concerns resonant subprocesses.
Note that the libraries should be created (source code), but not be
compiled here. This is done afterwards.
<<Commands: procedures>>=
subroutine spawn_extra_libraries (libname, local, global, libname_extra)
type(string_t), intent(in) :: libname
type(rt_data_t), intent(inout), target :: local
type(rt_data_t), intent(inout), target :: global
type(string_t), dimension(:), allocatable, intent(out) :: libname_extra
type(string_t), dimension(:), allocatable :: libname_res
allocate (libname_extra (0))
call spawn_resonant_subprocess_libraries &
(libname, local, global, libname_res)
if (allocated (libname_res)) libname_extra = [libname_extra, libname_res]
end subroutine spawn_extra_libraries
@ %def spawn_extra_libraries
@
\subsubsection{Execute a shell command}
The argument is a string expression.
<<Commands: types>>=
type, extends (command_t) :: cmd_exec_t
private
type(parse_node_t), pointer :: pn_command => null ()
contains
<<Commands: cmd exec: TBP>>
end type cmd_exec_t
@ %def cmd_exec_t
@ Simply tell the status.
<<Commands: cmd exec: TBP>>=
procedure :: write => cmd_exec_write
<<Commands: sub interfaces>>=
module subroutine cmd_exec_write (cmd, unit, indent)
class(cmd_exec_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_exec_write
<<Commands: procedures>>=
module subroutine cmd_exec_write (cmd, unit, indent)
class(cmd_exec_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
if (associated (cmd%pn_command)) then
write (u, "(1x,A)") "exec: [command associated]"
else
write (u, "(1x,A)") "exec: [undefined]"
end if
end subroutine cmd_exec_write
@ %def cmd_exec_write
@ Compile the exec command.
<<Commands: cmd exec: TBP>>=
procedure :: compile => cmd_exec_compile
<<Commands: sub interfaces>>=
module subroutine cmd_exec_compile (cmd, global)
class(cmd_exec_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_exec_compile
<<Commands: procedures>>=
module subroutine cmd_exec_compile (cmd, global)
class(cmd_exec_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_arg, pn_command
pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
pn_command => parse_node_get_sub_ptr (pn_arg)
cmd%pn_command => pn_command
end subroutine cmd_exec_compile
@ %def cmd_exec_compile
@ Execute the specified shell command.
<<Commands: cmd exec: TBP>>=
procedure :: execute => cmd_exec_execute
<<Commands: sub interfaces>>=
module subroutine cmd_exec_execute (cmd, global)
class(cmd_exec_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_exec_execute
<<Commands: procedures>>=
module subroutine cmd_exec_execute (cmd, global)
class(cmd_exec_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(string_t) :: command
logical :: is_known
integer :: status
command = eval_string (cmd%pn_command, global%var_list, is_known=is_known)
if (is_known) then
if (command /= "") then
call os_system_call (command, status, verbose=.true.)
if (status /= 0) then
write (msg_buffer, "(A,I0)") "Return code = ", status
call msg_message ()
call msg_error ("System command returned with nonzero status code")
end if
end if
end if
end subroutine cmd_exec_execute
@ %def cmd_exec_execute
@
\subsubsection{Variable declaration}
A variable can have various types. Hold the definition as an eval
tree.
There are intrinsic variables, user variables, and model variables.
The latter are further divided in independent variables and dependent
variables.
Regarding model variables: When dealing with them, we always look at
two variable lists in parallel. The global (or local) variable list
contains the user-visible values. It includes variables that
correspond to variables in the current model's list. These, in turn,
are pointers to the model's parameter list, so the model is always in
sync, internally. To keep the global variable list in sync with the
model, the global variables carry the [[is_copy]] property and contain
a separate pointer to the model variable. (The pointer is reassigned
whenever the model changes.) Modifying the global variable changes
two values simultaneously: the visible value and the model variable,
via this extra pointer. After each modification, we update dependent
parameters in the model variable list and re-synchronize the global
variable list (again, using these pointers) with the model variable
this. In the last step, modifications in the derived parameters
become visible.
When we integrate a process, we capture the current variable list of
the current model in a separate model instance, which is stored in the
process object. Thus, the model parameters associated to this process
at this time are preserved for the lifetime of the process object.
When we generate or rescan events, we can again capture a local model
variable list in a model instance. This allows us to reweight event
by event with different parameter sets simultaneously.
<<Commands: types>>=
type, extends (command_t) :: cmd_var_t
private
type(string_t) :: name
integer :: type = V_NONE
type(parse_node_t), pointer :: pn_value => null ()
logical :: is_intrinsic = .false.
logical :: is_model_var = .false.
contains
<<Commands: cmd var: TBP>>
end type cmd_var_t
@ %def cmd_var_t
@ Output. We know name, type, and properties, but not the value.
<<Commands: cmd var: TBP>>=
procedure :: write => cmd_var_write
<<Commands: sub interfaces>>=
module subroutine cmd_var_write (cmd, unit, indent)
class(cmd_var_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_var_write
<<Commands: procedures>>=
module subroutine cmd_var_write (cmd, unit, indent)
class(cmd_var_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,A,A)", advance="no") "var: ", char (cmd%name), " ("
select case (cmd%type)
case (V_NONE)
write (u, "(A)", advance="no") "[unknown]"
case (V_LOG)
write (u, "(A)", advance="no") "logical"
case (V_INT)
write (u, "(A)", advance="no") "int"
case (V_REAL)
write (u, "(A)", advance="no") "real"
case (V_CMPLX)
write (u, "(A)", advance="no") "complex"
case (V_STR)
write (u, "(A)", advance="no") "string"
case (V_PDG)
write (u, "(A)", advance="no") "alias"
end select
if (cmd%is_intrinsic) then
write (u, "(A)", advance="no") ", intrinsic"
end if
if (cmd%is_model_var) then
write (u, "(A)", advance="no") ", model"
end if
write (u, "(A)") ")"
end subroutine cmd_var_write
@ %def cmd_var_write
@ Compile the lhs and determine the variable name and type. Check whether
this variable can be created or modified as requested, and append the value to
the variable list, if appropriate. The value is initially undefined.
The rhs is assigned to a pointer, to be compiled and evaluated when the
command is executed.
<<Commands: cmd var: TBP>>=
procedure :: compile => cmd_var_compile
<<Commands: sub interfaces>>=
module subroutine cmd_var_compile (cmd, global)
class(cmd_var_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_var_compile
<<Commands: procedures>>=
module subroutine cmd_var_compile (cmd, global)
class(cmd_var_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_var, pn_name
type(parse_node_t), pointer :: pn_result, pn_proc
type(string_t) :: var_name
type(var_list_t), pointer :: model_vars
integer :: type
logical :: new
pn_result => null ()
new = .false.
select case (char (parse_node_get_rule_key (cmd%pn)))
case ("cmd_log_decl"); type = V_LOG
pn_var => parse_node_get_sub_ptr (cmd%pn, 2)
if (.not. associated (pn_var)) then ! handle masked syntax error
cmd%type = V_NONE; return
end if
pn_name => parse_node_get_sub_ptr (pn_var, 2)
new = .true.
case ("cmd_log"); type = V_LOG
pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
case ("cmd_int"); type = V_INT
pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
new = .true.
case ("cmd_real"); type = V_REAL
pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
new = .true.
case ("cmd_complex"); type = V_CMPLX
pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
new = .true.
case ("cmd_num"); type = V_NONE
pn_name => parse_node_get_sub_ptr (cmd%pn)
case ("cmd_string_decl"); type = V_STR
pn_var => parse_node_get_sub_ptr (cmd%pn, 2)
if (.not. associated (pn_var)) then ! handle masked syntax error
cmd%type = V_NONE; return
end if
pn_name => parse_node_get_sub_ptr (pn_var, 2)
new = .true.
case ("cmd_string"); type = V_STR
pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
case ("cmd_alias"); type = V_PDG
pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
new = .true.
case ("cmd_result"); type = V_REAL
pn_name => parse_node_get_sub_ptr (cmd%pn)
pn_result => parse_node_get_sub_ptr (pn_name)
pn_proc => parse_node_get_next_ptr (pn_result)
case default
call parse_node_mismatch &
("logical|int|real|complex|?|$|alias|var_name", cmd%pn) ! $
end select
if (.not. associated (pn_name)) then ! handle masked syntax error
cmd%type = V_NONE; return
end if
if (.not. associated (pn_result)) then
var_name = parse_node_get_string (pn_name)
else
var_name = parse_node_get_key (pn_result) &
// "(" // parse_node_get_string (pn_proc) // ")"
end if
select case (type)
case (V_LOG); var_name = "?" // var_name
case (V_STR); var_name = "$" // var_name ! $
end select
if (associated (global%model)) then
model_vars => global%model%get_var_list_ptr ()
else
model_vars => null ()
end if
call var_list_check_observable (global%var_list, var_name, type)
call var_list_check_result_var (global%var_list, var_name, type)
call global%var_list%check_user_var (var_name, type, new)
cmd%name = var_name
cmd%pn_value => parse_node_get_next_ptr (pn_name, 2)
if (global%var_list%contains (cmd%name, follow_link = .false.)) then
! local variable
cmd%is_intrinsic = &
global%var_list%is_intrinsic (cmd%name, follow_link = .false.)
cmd%type = &
global%var_list%get_type (cmd%name, follow_link = .false.)
else
if (new) cmd%type = type
if (global%var_list%contains (cmd%name, follow_link = .true.)) then
! global variable
cmd%is_intrinsic = &
global%var_list%is_intrinsic (cmd%name, follow_link = .true.)
if (cmd%type == V_NONE) then
cmd%type = &
global%var_list%get_type (cmd%name, follow_link = .true.)
end if
else if (associated (model_vars)) then ! check model variable
cmd%is_model_var = &
model_vars%contains (cmd%name)
if (cmd%type == V_NONE) then
cmd%type = &
model_vars%get_type (cmd%name)
end if
end if
if (cmd%type == V_NONE) then
call msg_fatal ("Variable '" // char (cmd%name) // "' " &
// "set without declaration")
cmd%type = V_NONE; return
end if
if (cmd%is_model_var) then
if (new) then
call msg_fatal ("Model variable '" // char (cmd%name) // "' " &
// "redeclared")
else if (model_vars%is_locked (cmd%name)) then
call msg_fatal ("Model variable '" // char (cmd%name) // "' " &
// "is locked")
end if
else
select case (cmd%type)
case (V_LOG)
call global%var_list%append_log (cmd%name, &
intrinsic=cmd%is_intrinsic, user=.true.)
case (V_INT)
call global%var_list%append_int (cmd%name, &
intrinsic=cmd%is_intrinsic, user=.true.)
case (V_REAL)
call global%var_list%append_real (cmd%name, &
intrinsic=cmd%is_intrinsic, user=.true.)
case (V_CMPLX)
call global%var_list%append_cmplx (cmd%name, &
intrinsic=cmd%is_intrinsic, user=.true.)
case (V_PDG)
call global%var_list%append_pdg_array (cmd%name, &
intrinsic=cmd%is_intrinsic, user=.true.)
case (V_STR)
call global%var_list%append_string (cmd%name, &
intrinsic=cmd%is_intrinsic, user=.true.)
end select
end if
end if
end subroutine cmd_var_compile
@ %def cmd_var_compile
@ Execute. Evaluate the definition and assign the variable value.
If the variable is a model variable, take a snapshot of the model if necessary
and set the variable in the local model.
<<Commands: cmd var: TBP>>=
procedure :: execute => cmd_var_execute
<<Commands: sub interfaces>>=
module subroutine cmd_var_execute (cmd, global)
class(cmd_var_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_var_execute
<<Commands: procedures>>=
module subroutine cmd_var_execute (cmd, global)
class(cmd_var_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
real(default) :: rval
logical :: is_known, pacified
var_list => global%get_var_list_ptr ()
if (cmd%is_model_var) then
pacified = var_list%get_lval (var_str ("?pacify"))
rval = eval_real (cmd%pn_value, var_list, is_known=is_known)
call global%model_set_real &
(cmd%name, rval, verbose=.true., pacified=pacified)
else if (cmd%type /= V_NONE) then
call cmd%set_value (var_list, verbose=.true.)
end if
end subroutine cmd_var_execute
@ %def cmd_var_execute
@ Copy the value to the variable list, where the variable should already exist.
<<Commands: cmd var: TBP>>=
procedure :: set_value => cmd_var_set_value
<<Commands: sub interfaces>>=
module subroutine cmd_var_set_value (var, var_list, verbose, model_name)
class(cmd_var_t), intent(inout) :: var
type(var_list_t), intent(inout), target :: var_list
logical, intent(in), optional :: verbose
type(string_t), intent(in), optional :: model_name
end subroutine cmd_var_set_value
<<Commands: procedures>>=
module subroutine cmd_var_set_value (var, var_list, verbose, model_name)
class(cmd_var_t), intent(inout) :: var
type(var_list_t), intent(inout), target :: var_list
logical, intent(in), optional :: verbose
type(string_t), intent(in), optional :: model_name
logical :: lval, pacified
integer :: ival
real(default) :: rval
complex(default) :: cval
type(pdg_array_t) :: aval
type(string_t) :: sval
logical :: is_known
pacified = var_list%get_lval (var_str ("?pacify"))
select case (var%type)
case (V_LOG)
lval = eval_log (var%pn_value, var_list, is_known=is_known)
call var_list%set_log (var%name, &
lval, is_known, verbose=verbose, model_name=model_name)
case (V_INT)
ival = eval_int (var%pn_value, var_list, is_known=is_known)
call var_list%set_int (var%name, &
ival, is_known, verbose=verbose, model_name=model_name)
case (V_REAL)
rval = eval_real (var%pn_value, var_list, is_known=is_known)
call var_list%set_real (var%name, &
rval, is_known, verbose=verbose, &
model_name=model_name, pacified = pacified)
case (V_CMPLX)
cval = eval_cmplx (var%pn_value, var_list, is_known=is_known)
call var_list%set_cmplx (var%name, &
cval, is_known, verbose=verbose, &
model_name=model_name, pacified = pacified)
case (V_PDG)
aval = eval_pdg_array (var%pn_value, var_list, is_known=is_known)
call var_list%set_pdg_array (var%name, &
aval, is_known, verbose=verbose, model_name=model_name)
case (V_STR)
sval = eval_string (var%pn_value, var_list, is_known=is_known)
call var_list%set_string (var%name, &
sval, is_known, verbose=verbose, model_name=model_name)
end select
end subroutine cmd_var_set_value
@ %def cmd_var_set_value
@
\subsubsection{SLHA}
Read a SLHA (SUSY Les Houches Accord) file to fill the appropriate
model parameters. We do not access the current variable record, but
directly work on the appropriate SUSY model, which is loaded if
necessary.
We may be in read or write mode. In the latter case, we may write
just input parameters, or the complete spectrum, or the spectrum with
all decays.
<<Commands: types>>=
type, extends (command_t) :: cmd_slha_t
private
type(string_t) :: file
logical :: write_mode = .false.
contains
<<Commands: cmd slha: TBP>>
end type cmd_slha_t
@ %def cmd_slha_t
@ Output.
<<Commands: cmd slha: TBP>>=
procedure :: write => cmd_slha_write
<<Commands: sub interfaces>>=
module subroutine cmd_slha_write (cmd, unit, indent)
class(cmd_slha_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_slha_write
<<Commands: procedures>>=
module subroutine cmd_slha_write (cmd, unit, indent)
class(cmd_slha_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,A)") "slha: file name = ", char (cmd%file)
write (u, "(1x,A,L1)") "slha: write mode = ", cmd%write_mode
end subroutine cmd_slha_write
@ %def cmd_slha_write
@ Compile. Read the filename and store it.
<<Commands: cmd slha: TBP>>=
procedure :: compile => cmd_slha_compile
<<Commands: sub interfaces>>=
module subroutine cmd_slha_compile (cmd, global)
class(cmd_slha_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_slha_compile
<<Commands: procedures>>=
module subroutine cmd_slha_compile (cmd, global)
class(cmd_slha_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_key, pn_arg, pn_file
pn_key => parse_node_get_sub_ptr (cmd%pn)
pn_arg => parse_node_get_next_ptr (pn_key)
pn_file => parse_node_get_sub_ptr (pn_arg)
call cmd%compile_options (global)
cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
select case (char (parse_node_get_key (pn_key)))
case ("read_slha")
cmd%write_mode = .false.
case ("write_slha")
cmd%write_mode = .true.
case default
call parse_node_mismatch ("read_slha|write_slha", cmd%pn)
end select
cmd%file = parse_node_get_string (pn_file)
end subroutine cmd_slha_compile
@ %def cmd_slha_compile
@ Execute. Read or write the specified SLHA file. Behind the scenes,
this will first read the WHIZARD model file, then read the SLHA file
and assign the SLHA parameters as far as determined by
[[dispatch_slha]]. Finally, the global variables are synchronized
with the model. This is similar to executing [[cmd_model]].
<<Commands: cmd slha: TBP>>=
procedure :: execute => cmd_slha_execute
<<Commands: sub interfaces>>=
module subroutine cmd_slha_execute (cmd, global)
class(cmd_slha_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_slha_execute
<<Commands: procedures>>=
module subroutine cmd_slha_execute (cmd, global)
class(cmd_slha_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
logical :: input, spectrum, decays
if (cmd%write_mode) then
input = .true.
spectrum = .false.
decays = .false.
if (.not. associated (cmd%local%model)) then
call msg_fatal ("SLHA: local model not associated")
return
end if
call slha_write_file &
(cmd%file, cmd%local%model, &
input = input, spectrum = spectrum, decays = decays)
else
if (.not. associated (global%model)) then
call msg_fatal ("SLHA: global model not associated")
return
end if
call dispatch_slha (cmd%local%var_list, &
input = input, spectrum = spectrum, decays = decays)
call global%ensure_model_copy ()
call slha_read_file &
(cmd%file, cmd%local%os_data, global%model, &
input = input, spectrum = spectrum, decays = decays)
end if
end subroutine cmd_slha_execute
@ %def cmd_slha_execute
@
\subsubsection{Show values}
This command shows the current values of variables or other objects,
in a suitably condensed form.
<<Commands: types>>=
type, extends (command_t) :: cmd_show_t
private
type(string_t), dimension(:), allocatable :: name
contains
<<Commands: cmd show: TBP>>
end type cmd_show_t
@ %def cmd_show_t
@ Output: list the object names, not values.
<<Commands: cmd show: TBP>>=
procedure :: write => cmd_show_write
<<Commands: sub interfaces>>=
module subroutine cmd_show_write (cmd, unit, indent)
class(cmd_show_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_show_write
<<Commands: procedures>>=
module subroutine cmd_show_write (cmd, unit, indent)
class(cmd_show_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)", advance="no") "show: "
if (allocated (cmd%name)) then
do i = 1, size (cmd%name)
write (u, "(1x,A)", advance="no") char (cmd%name(i))
end do
write (u, *)
else
write (u, "(5x,A)") "[undefined]"
end if
end subroutine cmd_show_write
@ %def cmd_show_write
@ Compile. Allocate an array which is filled with the names of the
variables to show.
<<Commands: cmd show: TBP>>=
procedure :: compile => cmd_show_compile
<<Commands: sub interfaces>>=
module subroutine cmd_show_compile (cmd, global)
class(cmd_show_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_show_compile
<<Commands: procedures>>=
module subroutine cmd_show_compile (cmd, global)
class(cmd_show_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name
type(string_t) :: key
integer :: i, n_args
pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
if (associated (pn_arg)) then
select case (char (parse_node_get_rule_key (pn_arg)))
case ("show_arg")
cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
case default
cmd%pn_opt => pn_arg
pn_arg => null ()
end select
end if
call cmd%compile_options (global)
if (associated (pn_arg)) then
n_args = parse_node_get_n_sub (pn_arg)
allocate (cmd%name (n_args))
pn_var => parse_node_get_sub_ptr (pn_arg)
i = 0
do while (associated (pn_var))
i = i + 1
select case (char (parse_node_get_rule_key (pn_var)))
case ("model", "library", "beams", "iterations", &
"cuts", "weight", "int", "real", "complex", &
"scale", "factorization_scale", "renormalization_scale", &
"selection", "reweight", "analysis", "pdg", &
"stable", "unstable", "polarized", "unpolarized", &
"results", "expect", "intrinsic", "string", "logical")
cmd%name(i) = parse_node_get_key (pn_var)
case ("result_var")
pn_prefix => parse_node_get_sub_ptr (pn_var)
pn_name => parse_node_get_next_ptr (pn_prefix)
if (associated (pn_name)) then
cmd%name(i) = parse_node_get_key (pn_prefix) &
// "(" // parse_node_get_string (pn_name) // ")"
else
cmd%name(i) = parse_node_get_key (pn_prefix)
end if
case ("log_var", "string_var", "alias_var")
pn_prefix => parse_node_get_sub_ptr (pn_var)
pn_name => parse_node_get_next_ptr (pn_prefix)
key = parse_node_get_key (pn_prefix)
if (associated (pn_name)) then
select case (char (parse_node_get_rule_key (pn_name)))
case ("var_name")
select case (char (key))
case ("?", "$") ! $ sign
cmd%name(i) = key // parse_node_get_string (pn_name)
case ("alias")
cmd%name(i) = parse_node_get_string (pn_name)
end select
case default
call parse_node_mismatch &
("var_name", pn_name)
end select
else
cmd%name(i) = key
end if
case default
cmd%name(i) = parse_node_get_string (pn_var)
end select
pn_var => parse_node_get_next_ptr (pn_var)
end do
else
allocate (cmd%name (0))
end if
end subroutine cmd_show_compile
@ %def cmd_show_compile
@ Execute. Scan the list of objects to show.
<<Commands: parameters>>=
integer, parameter, public :: SHOW_BUFFER_SIZE = 4096
<<Commands: cmd show: TBP>>=
procedure :: execute => cmd_show_execute
<<Commands: sub interfaces>>=
module subroutine cmd_show_execute (cmd, global)
class(cmd_show_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_show_execute
<<Commands: procedures>>=
module subroutine cmd_show_execute (cmd, global)
class(cmd_show_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list, model_vars
type(model_t), pointer :: model
type(string_t) :: name
integer :: n, pdg
type(flavor_t) :: flv
type(process_library_t), pointer :: prc_lib
type(process_t), pointer :: process
logical :: pacified
character(SHOW_BUFFER_SIZE) :: buffer
type(string_t) :: out_file
integer :: i, j, u, u_log, u_out, u_ext
u = free_unit ()
var_list => cmd%local%var_list
if (associated (cmd%local%model)) then
model_vars => cmd%local%model%get_var_list_ptr ()
else
model_vars => null ()
end if
pacified = var_list%get_lval (var_str ("?pacify"))
out_file = var_list%get_sval (var_str ("$out_file"))
if (file_list_is_open (global%out_files, out_file, action="write")) then
call msg_message ("show: copying output to file '" &
// char (out_file) // "'")
u_ext = file_list_get_unit (global%out_files, out_file)
else
u_ext = -1
end if
open (u, status = "scratch", action = "readwrite")
if (associated (cmd%local%model)) then
name = cmd%local%model%get_name ()
end if
if (size (cmd%name) == 0) then
if (associated (model_vars)) then
call model_vars%write (model_name = name, &
unit = u, pacified = pacified, follow_link = .false.)
end if
call var_list%write (unit = u, pacified = pacified)
else
do i = 1, size (cmd%name)
select case (char (cmd%name(i)))
case ("model")
if (associated (cmd%local%model)) then
call cmd%local%model%show (u)
else
write (u, "(A)") "Model: [undefined]"
end if
case ("library")
if (associated (cmd%local%prclib)) then
call cmd%local%prclib%show (u)
else
write (u, "(A)") "Process library: [undefined]"
end if
case ("beams")
call cmd%local%show_beams (u)
case ("iterations")
call cmd%local%it_list%write (u)
case ("results")
call cmd%local%process_stack%show (u, fifo=.true.)
case ("stable")
call cmd%local%model%show_stable (u)
case ("polarized")
call cmd%local%model%show_polarized (u)
case ("unpolarized")
call cmd%local%model%show_unpolarized (u)
case ("unstable")
model => cmd%local%model
call model%show_unstable (u)
n = model%get_n_field ()
do j = 1, n
pdg = model%get_pdg (j)
call flv%init (pdg, model)
if (.not. flv%is_stable ()) &
call show_unstable (cmd%local, pdg, u)
if (flv%has_antiparticle ()) then
associate (anti => flv%anti ())
if (.not. anti%is_stable ()) &
call show_unstable (cmd%local, -pdg, u)
end associate
end if
end do
case ("cuts", "weight", "scale", &
"factorization_scale", "renormalization_scale", &
"selection", "reweight", "analysis")
call cmd%local%pn%show (cmd%name(i), u)
case ("expect")
call expect_summary (force = .true.)
case ("intrinsic")
call var_list%write (intrinsic=.true., unit=u, &
pacified = pacified)
case ("logical")
if (associated (model_vars)) then
call model_vars%write (only_type=V_LOG, &
model_name = name, unit=u, pacified = pacified, &
follow_link=.false.)
end if
call var_list%write (&
only_type=V_LOG, unit=u, pacified = pacified)
case ("int")
if (associated (model_vars)) then
call model_vars%write (only_type=V_INT, &
model_name = name, unit=u, pacified = pacified, &
follow_link=.false.)
end if
call var_list%write (only_type=V_INT, &
unit=u, pacified = pacified)
case ("real")
if (associated (model_vars)) then
call model_vars%write (only_type=V_REAL, &
model_name = name, unit=u, pacified = pacified, &
follow_link=.false.)
end if
call var_list%write (only_type=V_REAL, &
unit=u, pacified = pacified)
case ("complex")
if (associated (model_vars)) then
call model_vars%write (only_type=V_CMPLX, &
model_name = name, unit=u, pacified = pacified, &
follow_link=.false.)
end if
call var_list%write (only_type=V_CMPLX, &
unit=u, pacified = pacified)
case ("pdg")
if (associated (model_vars)) then
call model_vars%write (only_type=V_PDG, &
model_name = name, unit=u, pacified = pacified, &
follow_link=.false.)
end if
call var_list%write (only_type=V_PDG, &
unit=u, pacified = pacified)
case ("string")
if (associated (model_vars)) then
call model_vars%write (only_type=V_STR, &
model_name = name, unit=u, pacified = pacified, &
follow_link=.false.)
end if
call var_list%write (only_type=V_STR, &
unit=u, pacified = pacified)
case default
if (analysis_exists (cmd%name(i))) then
call analysis_write (cmd%name(i), u)
else if (cmd%local%process_stack%exists (cmd%name(i))) then
process => cmd%local%process_stack%get_process_ptr (cmd%name(i))
call process%show (u)
else if (associated (cmd%local%prclib_stack%get_library_ptr &
(cmd%name(i)))) then
prc_lib => cmd%local%prclib_stack%get_library_ptr (cmd%name(i))
call prc_lib%show (u)
else if (associated (model_vars)) then
if (model_vars%contains (cmd%name(i), follow_link=.false.)) then
call model_vars%write_var (cmd%name(i), &
unit = u, model_name = name, pacified = pacified)
else if (var_list%contains (cmd%name(i))) then
call var_list%write_var (cmd%name(i), &
unit = u, pacified = pacified)
else
call msg_error ("show: object '" // char (cmd%name(i)) &
// "' not found")
end if
else if (var_list%contains (cmd%name(i))) then
call var_list%write_var (cmd%name(i), &
unit = u, pacified = pacified)
else
call msg_error ("show: object '" // char (cmd%name(i)) &
// "' not found")
end if
end select
end do
end if
rewind (u)
u_log = logfile_unit ()
u_out = given_output_unit ()
do
read (u, "(A)", end = 1) buffer
if (u_log > 0) write (u_log, "(A)") trim (buffer)
if (u_out > 0) write (u_out, "(A)") trim (buffer)
if (u_ext > 0) write (u_ext, "(A)") trim (buffer)
end do
1 close (u)
if (u_log > 0) flush (u_log)
if (u_out > 0) flush (u_out)
if (u_ext > 0) flush (u_ext)
end subroutine cmd_show_execute
@ %def cmd_show_execute
@
\subsubsection{Clear values}
This command clears the current values of variables or other objects,
where this makes sense. It parallels the [[show]] command. The
objects are cleared, but not deleted.
<<Commands: types>>=
type, extends (command_t) :: cmd_clear_t
private
type(string_t), dimension(:), allocatable :: name
contains
<<Commands: cmd clear: TBP>>
end type cmd_clear_t
@ %def cmd_clear_t
@ Output: list the names of the objects to be cleared.
<<Commands: cmd clear: TBP>>=
procedure :: write => cmd_clear_write
<<Commands: sub interfaces>>=
module subroutine cmd_clear_write (cmd, unit, indent)
class(cmd_clear_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_clear_write
<<Commands: procedures>>=
module subroutine cmd_clear_write (cmd, unit, indent)
class(cmd_clear_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)", advance="no") "clear: "
if (allocated (cmd%name)) then
do i = 1, size (cmd%name)
write (u, "(1x,A)", advance="no") char (cmd%name(i))
end do
write (u, *)
else
write (u, "(5x,A)") "[undefined]"
end if
end subroutine cmd_clear_write
@ %def cmd_clear_write
@ Compile. Allocate an array which is filled with the names of the
objects to be cleared.
Note: there is currently no need to account for options, but we
prepare for that possibility.
<<Commands: cmd clear: TBP>>=
procedure :: compile => cmd_clear_compile
<<Commands: sub interfaces>>=
module subroutine cmd_clear_compile (cmd, global)
class(cmd_clear_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_clear_compile
<<Commands: procedures>>=
module subroutine cmd_clear_compile (cmd, global)
class(cmd_clear_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name
type(string_t) :: key
integer :: i, n_args
pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
if (associated (pn_arg)) then
select case (char (parse_node_get_rule_key (pn_arg)))
case ("clear_arg")
cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
case default
cmd%pn_opt => pn_arg
pn_arg => null ()
end select
end if
call cmd%compile_options (global)
if (associated (pn_arg)) then
n_args = parse_node_get_n_sub (pn_arg)
allocate (cmd%name (n_args))
pn_var => parse_node_get_sub_ptr (pn_arg)
i = 0
do while (associated (pn_var))
i = i + 1
select case (char (parse_node_get_rule_key (pn_var)))
case ("beams", "iterations", &
"cuts", "weight", &
"scale", "factorization_scale", "renormalization_scale", &
"selection", "reweight", "analysis", &
"unstable", "polarized", &
"expect")
cmd%name(i) = parse_node_get_key (pn_var)
case ("log_var", "string_var")
pn_prefix => parse_node_get_sub_ptr (pn_var)
pn_name => parse_node_get_next_ptr (pn_prefix)
key = parse_node_get_key (pn_prefix)
if (associated (pn_name)) then
select case (char (parse_node_get_rule_key (pn_name)))
case ("var_name")
select case (char (key))
case ("?", "$") ! $ sign
cmd%name(i) = key // parse_node_get_string (pn_name)
end select
case default
call parse_node_mismatch &
("var_name", pn_name)
end select
else
cmd%name(i) = key
end if
case default
cmd%name(i) = parse_node_get_string (pn_var)
end select
pn_var => parse_node_get_next_ptr (pn_var)
end do
else
allocate (cmd%name (0))
end if
end subroutine cmd_clear_compile
@ %def cmd_clear_compile
@ Execute. Scan the list of objects to clear.
Objects that can be shown but not cleared: model, library, results
<<Commands: cmd clear: TBP>>=
procedure :: execute => cmd_clear_execute
<<Commands: sub interfaces>>=
module subroutine cmd_clear_execute (cmd, global)
class(cmd_clear_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_clear_execute
<<Commands: procedures>>=
module subroutine cmd_clear_execute (cmd, global)
class(cmd_clear_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
integer :: i
logical :: success
type(var_list_t), pointer :: model_vars
if (size (cmd%name) == 0) then
call msg_warning ("clear: no object specified")
else
do i = 1, size (cmd%name)
success = .true.
select case (char (cmd%name(i)))
case ("beams")
call cmd%local%clear_beams ()
case ("iterations")
call cmd%local%it_list%clear ()
case ("polarized")
call cmd%local%model%clear_polarized ()
case ("unstable")
call cmd%local%model%clear_unstable ()
case ("cuts", "weight", "scale", &
"factorization_scale", "renormalization_scale", &
"selection", "reweight", "analysis")
call cmd%local%pn%clear (cmd%name(i))
case ("expect")
call expect_clear ()
case default
if (analysis_exists (cmd%name(i))) then
call analysis_clear (cmd%name(i))
else if (cmd%local%var_list%contains (cmd%name(i))) then
if (.not. cmd%local%var_list%is_locked (cmd%name(i))) then
call cmd%local%var_list%unset (cmd%name(i))
else
call msg_error ("clear: variable '" // char (cmd%name(i)) &
// "' is locked and can't be cleared")
success = .false.
end if
else if (associated (cmd%local%model)) then
model_vars => cmd%local%model%get_var_list_ptr ()
if (model_vars%contains (cmd%name(i), follow_link=.false.)) then
call msg_error ("clear: variable '" // char (cmd%name(i)) &
// "' is a model variable and can't be cleared")
else
call msg_error ("clear: object '" // char (cmd%name(i)) &
// "' not found")
end if
success = .false.
else
call msg_error ("clear: object '" // char (cmd%name(i)) &
// "' not found")
success = .false.
end if
end select
if (success) call msg_message ("cleared: " // char (cmd%name(i)))
end do
end if
end subroutine cmd_clear_execute
@ %def cmd_clear_execute
@
\subsubsection{Compare values of variables to expectation}
The implementation is similar to the [[show]] command. There are just
two arguments: two values that should be compared. For providing
local values for the numerical tolerance, the command has a local
argument list.
If the expectation fails, an error condition is recorded.
<<Commands: types>>=
type, extends (command_t) :: cmd_expect_t
private
type(parse_node_t), pointer :: pn_lexpr => null ()
contains
<<Commands: cmd expect: TBP>>
end type cmd_expect_t
@ %def cmd_expect_t
@ Simply tell the status.
<<Commands: cmd expect: TBP>>=
procedure :: write => cmd_expect_write
<<Commands: sub interfaces>>=
module subroutine cmd_expect_write (cmd, unit, indent)
class(cmd_expect_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_expect_write
<<Commands: procedures>>=
module subroutine cmd_expect_write (cmd, unit, indent)
class(cmd_expect_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
if (associated (cmd%pn_lexpr)) then
write (u, "(1x,A)") "expect: [expression associated]"
else
write (u, "(1x,A)") "expect: [undefined]"
end if
end subroutine cmd_expect_write
@ %def cmd_expect_write
@ Compile. This merely assigns the parse node, the actual compilation is done
at execution. This is necessary because the origin of variables
(local/global) may change during execution.
<<Commands: cmd expect: TBP>>=
procedure :: compile => cmd_expect_compile
<<Commands: sub interfaces>>=
module subroutine cmd_expect_compile (cmd, global)
class(cmd_expect_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_expect_compile
<<Commands: procedures>>=
module subroutine cmd_expect_compile (cmd, global)
class(cmd_expect_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_arg
pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
cmd%pn_lexpr => parse_node_get_sub_ptr (pn_arg)
call cmd%compile_options (global)
end subroutine cmd_expect_compile
@ %def cmd_expect_compile
@ Execute. Evaluate both arguments, print them and their difference
(if numerical), and whether they agree. Record the result.
<<Commands: cmd expect: TBP>>=
procedure :: execute => cmd_expect_execute
<<Commands: sub interfaces>>=
module subroutine cmd_expect_execute (cmd, global)
class(cmd_expect_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_expect_execute
<<Commands: procedures>>=
module subroutine cmd_expect_execute (cmd, global)
class(cmd_expect_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
logical :: success, is_known
var_list => cmd%local%get_var_list_ptr ()
success = eval_log (cmd%pn_lexpr, var_list, is_known=is_known)
if (is_known) then
if (success) then
call msg_message ("expect: success")
else
call msg_error ("expect: failure")
end if
else
call msg_error ("expect: undefined result")
success = .false.
end if
call expect_record (success)
end subroutine cmd_expect_execute
@ %def cmd_expect_execute
@
\subsubsection{Beams}
The beam command includes both beam and structure-function
definition.
<<Commands: types>>=
type, extends (command_t) :: cmd_beams_t
private
integer :: n_in = 0
type(parse_node_p), dimension(:), allocatable :: pn_pdg
integer :: n_sf_record = 0
integer, dimension(:), allocatable :: n_entry
type(parse_node_p), dimension(:,:), allocatable :: pn_sf_entry
contains
<<Commands: cmd beams: TBP>>
end type cmd_beams_t
@ %def cmd_beams_t
@ Output. The particle expressions are not resolved.
<<Commands: cmd beams: TBP>>=
procedure :: write => cmd_beams_write
<<Commands: sub interfaces>>=
module subroutine cmd_beams_write (cmd, unit, indent)
class(cmd_beams_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_beams_write
<<Commands: procedures>>=
module subroutine cmd_beams_write (cmd, unit, indent)
class(cmd_beams_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
select case (cmd%n_in)
case (1)
write (u, "(1x,A)") "beams: 1 [decay]"
case (2)
write (u, "(1x,A)") "beams: 2 [scattering]"
case default
write (u, "(1x,A)") "beams: [undefined]"
end select
if (allocated (cmd%n_entry)) then
if (cmd%n_sf_record > 0) then
write (u, "(1x,A,99(1x,I0))") "structure function entries:", &
cmd%n_entry
end if
end if
end subroutine cmd_beams_write
@ %def cmd_beams_write
@ Compile. Find and assign the parse nodes.
Note: local environments are not yet supported.
<<Commands: cmd beams: TBP>>=
procedure :: compile => cmd_beams_compile
<<Commands: sub interfaces>>=
module subroutine cmd_beams_compile (cmd, global)
class(cmd_beams_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_beams_compile
<<Commands: procedures>>=
module subroutine cmd_beams_compile (cmd, global)
class(cmd_beams_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_beam_def, pn_beam_spec
type(parse_node_t), pointer :: pn_beam_list
type(parse_node_t), pointer :: pn_codes
type(parse_node_t), pointer :: pn_strfun_seq, pn_strfun_pair
type(parse_node_t), pointer :: pn_strfun_def
integer :: i
pn_beam_def => parse_node_get_sub_ptr (cmd%pn, 3)
pn_beam_spec => parse_node_get_sub_ptr (pn_beam_def)
pn_strfun_seq => parse_node_get_next_ptr (pn_beam_spec)
pn_beam_list => parse_node_get_sub_ptr (pn_beam_spec)
call cmd%compile_options (global)
cmd%n_in = parse_node_get_n_sub (pn_beam_list)
allocate (cmd%pn_pdg (cmd%n_in))
pn_codes => parse_node_get_sub_ptr (pn_beam_list)
do i = 1, cmd%n_in
cmd%pn_pdg(i)%ptr => pn_codes
pn_codes => parse_node_get_next_ptr (pn_codes)
end do
if (associated (pn_strfun_seq)) then
cmd%n_sf_record = parse_node_get_n_sub (pn_beam_def) - 1
allocate (cmd%n_entry (cmd%n_sf_record), source = 1)
allocate (cmd%pn_sf_entry (2, cmd%n_sf_record))
do i = 1, cmd%n_sf_record
pn_strfun_pair => parse_node_get_sub_ptr (pn_strfun_seq, 2)
pn_strfun_def => parse_node_get_sub_ptr (pn_strfun_pair)
cmd%pn_sf_entry(1,i)%ptr => pn_strfun_def
pn_strfun_def => parse_node_get_next_ptr (pn_strfun_def)
cmd%pn_sf_entry(2,i)%ptr => pn_strfun_def
if (associated (pn_strfun_def)) cmd%n_entry(i) = 2
pn_strfun_seq => parse_node_get_next_ptr (pn_strfun_seq)
end do
else
allocate (cmd%n_entry (0))
allocate (cmd%pn_sf_entry (0, 0))
end if
end subroutine cmd_beams_compile
@ %def cmd_beams_compile
@ Command execution: Determine beam particles and structure-function
names, if any. The results are stored in the [[beam_structure]]
component of the [[global]] data block.
<<Commands: cmd beams: TBP>>=
procedure :: execute => cmd_beams_execute
<<Commands: sub interfaces>>=
module subroutine cmd_beams_execute (cmd, global)
class(cmd_beams_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_beams_execute
<<Commands: procedures>>=
module subroutine cmd_beams_execute (cmd, global)
class(cmd_beams_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
type(pdg_array_t) :: pdg_array
integer, dimension(:), allocatable :: pdg
type(flavor_t), dimension(:), allocatable :: flv
type(parse_node_t), pointer :: pn_key
type(string_t) :: sf_name
integer :: i, j
call lhapdf_global_reset ()
var_list => cmd%local%get_var_list_ptr ()
allocate (flv (cmd%n_in))
do i = 1, cmd%n_in
pdg_array = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list)
pdg = pdg_array
select case (size (pdg))
case (1)
call flv(i)%init ( pdg(1), cmd%local%model)
case default
call msg_fatal ("Beams: beam particles must be unique")
end select
end do
select case (cmd%n_in)
case (1)
if (cmd%n_sf_record > 0) then
call msg_fatal ("Beam setup: no structure functions allowed &
&for decay")
end if
call global%beam_structure%init_sf (flv%get_name ())
case (2)
call global%beam_structure%init_sf (flv%get_name (), cmd%n_entry)
do i = 1, cmd%n_sf_record
do j = 1, cmd%n_entry(i)
pn_key => parse_node_get_sub_ptr (cmd%pn_sf_entry(j,i)%ptr)
sf_name = parse_node_get_key (pn_key)
call global%beam_structure%set_sf (i, j, sf_name)
end do
end do
end select
end subroutine cmd_beams_execute
@ %def cmd_beams_execute
@
\subsubsection{Density matrices for beam polarization}
For holding beam polarization, we define a notation and a data
structure for sparse matrices. The entries (and the index
expressions) are numerical expressions, so we use evaluation trees.
Each entry in the sparse matrix is an n-tuple of expressions. The first
tuple elements represent index values, the last one is an arbitrary
(complex) number. Absent expressions are replaced by default-value rules.
Note: Here, and in some other commands, we would like to store an evaluation
tree, not just a parse node pointer. However, the current expression handler
wants all variables defined, so the evaluation tree can only be built by
[[evaluate]], i.e., compiled just-in-time and evaluated immediately.
<<Commands: types>>=
type :: sentry_expr_t
type(parse_node_p), dimension(:), allocatable :: expr
contains
<<Commands: sentry expr: TBP>>
end type sentry_expr_t
@ %def sentry_expr_t
@ Compile parse nodes into evaluation trees.
<<Commands: sentry expr: TBP>>=
procedure :: compile => sentry_expr_compile
<<Commands: sub interfaces>>=
module subroutine sentry_expr_compile (sentry, pn)
class(sentry_expr_t), intent(out) :: sentry
type(parse_node_t), intent(in), target :: pn
end subroutine sentry_expr_compile
<<Commands: procedures>>=
module subroutine sentry_expr_compile (sentry, pn)
class(sentry_expr_t), intent(out) :: sentry
type(parse_node_t), intent(in), target :: pn
type(parse_node_t), pointer :: pn_expr, pn_extra
integer :: n_expr, i
n_expr = parse_node_get_n_sub (pn)
allocate (sentry%expr (n_expr))
if (n_expr > 0) then
i = 0
pn_expr => parse_node_get_sub_ptr (pn)
pn_extra => parse_node_get_next_ptr (pn_expr)
do i = 1, n_expr
sentry%expr(i)%ptr => pn_expr
if (associated (pn_extra)) then
pn_expr => parse_node_get_sub_ptr (pn_extra, 2)
pn_extra => parse_node_get_next_ptr (pn_extra)
end if
end do
end if
end subroutine sentry_expr_compile
@ %def sentry_expr_compile
@ Evaluate the expressions and return an index array of predefined
length together with a complex value. If the value (as the last expression)
is undefined, set it to unity. If index values are undefined, repeat
the previous index value.
<<Commands: sentry expr: TBP>>=
procedure :: evaluate => sentry_expr_evaluate
<<Commands: sub interfaces>>=
module subroutine sentry_expr_evaluate (sentry, index, value, global)
class(sentry_expr_t), intent(inout) :: sentry
integer, dimension(:), intent(out) :: index
complex(default), intent(out) :: value
type(rt_data_t), intent(in), target :: global
end subroutine sentry_expr_evaluate
<<Commands: procedures>>=
module subroutine sentry_expr_evaluate (sentry, index, value, global)
class(sentry_expr_t), intent(inout) :: sentry
integer, dimension(:), intent(out) :: index
complex(default), intent(out) :: value
type(rt_data_t), intent(in), target :: global
type(var_list_t), pointer :: var_list
integer :: i, n_expr, n_index
type(eval_tree_t) :: eval_tree
var_list => global%get_var_list_ptr ()
n_expr = size (sentry%expr)
n_index = size (index)
if (n_expr <= n_index + 1) then
do i = 1, min (n_expr, n_index)
associate (expr => sentry%expr(i))
call eval_tree%init_expr (expr%ptr, var_list)
call eval_tree%evaluate ()
if (eval_tree%is_known ()) then
index(i) = eval_tree%get_int ()
else
call msg_fatal ("Evaluating density matrix: undefined index")
end if
end associate
end do
do i = n_expr + 1, n_index
index(i) = index(n_expr)
end do
if (n_expr == n_index + 1) then
associate (expr => sentry%expr(n_expr))
call eval_tree%init_expr (expr%ptr, var_list)
call eval_tree%evaluate ()
if (eval_tree%is_known ()) then
value = eval_tree%get_cmplx ()
else
call msg_fatal ("Evaluating density matrix: undefined index")
end if
call eval_tree%final ()
end associate
else
value = 1
end if
else
call msg_fatal ("Evaluating density matrix: index expression too long")
end if
end subroutine sentry_expr_evaluate
@ %def sentry_expr_evaluate
@ The sparse matrix itself consists of an arbitrary number of entries.
<<Commands: types>>=
type :: smatrix_expr_t
type(sentry_expr_t), dimension(:), allocatable :: entry
contains
<<Commands: smatrix expr: TBP>>
end type smatrix_expr_t
@ %def smatrix_expr_t
@ Compile: assign sub-nodes to sentry-expressions and compile those.
<<Commands: smatrix expr: TBP>>=
procedure :: compile => smatrix_expr_compile
<<Commands: sub interfaces>>=
module subroutine smatrix_expr_compile (smatrix_expr, pn)
class(smatrix_expr_t), intent(out) :: smatrix_expr
type(parse_node_t), intent(in), target :: pn
end subroutine smatrix_expr_compile
<<Commands: procedures>>=
module subroutine smatrix_expr_compile (smatrix_expr, pn)
class(smatrix_expr_t), intent(out) :: smatrix_expr
type(parse_node_t), intent(in), target :: pn
type(parse_node_t), pointer :: pn_arg, pn_entry
integer :: n_entry, i
pn_arg => parse_node_get_sub_ptr (pn, 2)
if (associated (pn_arg)) then
n_entry = parse_node_get_n_sub (pn_arg)
allocate (smatrix_expr%entry (n_entry))
pn_entry => parse_node_get_sub_ptr (pn_arg)
do i = 1, n_entry
call smatrix_expr%entry(i)%compile (pn_entry)
pn_entry => parse_node_get_next_ptr (pn_entry)
end do
else
allocate (smatrix_expr%entry (0))
end if
end subroutine smatrix_expr_compile
@ %def smatrix_expr_compile
@ Evaluate the entries and build a new [[smatrix]] object, which
contains just the numerical results.
<<Commands: smatrix expr: TBP>>=
procedure :: evaluate => smatrix_expr_evaluate
<<Commands: sub interfaces>>=
module subroutine smatrix_expr_evaluate (smatrix_expr, smatrix, global)
class(smatrix_expr_t), intent(inout) :: smatrix_expr
type(smatrix_t), intent(out) :: smatrix
type(rt_data_t), intent(in), target :: global
end subroutine smatrix_expr_evaluate
<<Commands: procedures>>=
module subroutine smatrix_expr_evaluate (smatrix_expr, smatrix, global)
class(smatrix_expr_t), intent(inout) :: smatrix_expr
type(smatrix_t), intent(out) :: smatrix
type(rt_data_t), intent(in), target :: global
integer, dimension(2) :: idx
complex(default) :: value
integer :: i, n_entry
n_entry = size (smatrix_expr%entry)
call smatrix%init (2, n_entry)
do i = 1, n_entry
call smatrix_expr%entry(i)%evaluate (idx, value, global)
call smatrix%set_entry (i, idx, value)
end do
end subroutine smatrix_expr_evaluate
@ %def smatrix_expr_evaluate
@
\subsubsection{Beam polarization density}
The beam polarization command defines spin density matrix for one or
two beams (scattering or decay).
<<Commands: types>>=
type, extends (command_t) :: cmd_beams_pol_density_t
private
integer :: n_in = 0
type(smatrix_expr_t), dimension(:), allocatable :: smatrix
contains
<<Commands: cmd beams pol density: TBP>>
end type cmd_beams_pol_density_t
@ %def cmd_beams_pol_density_t
@ Output.
<<Commands: cmd beams pol density: TBP>>=
procedure :: write => cmd_beams_pol_density_write
<<Commands: sub interfaces>>=
module subroutine cmd_beams_pol_density_write (cmd, unit, indent)
class(cmd_beams_pol_density_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_beams_pol_density_write
<<Commands: procedures>>=
module subroutine cmd_beams_pol_density_write (cmd, unit, indent)
class(cmd_beams_pol_density_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
select case (cmd%n_in)
case (1)
write (u, "(1x,A)") "beams polarization setup: 1 [decay]"
case (2)
write (u, "(1x,A)") "beams polarization setup: 2 [scattering]"
case default
write (u, "(1x,A)") "beams polarization setup: [undefined]"
end select
end subroutine cmd_beams_pol_density_write
@ %def cmd_beams_pol_density_write
@ Compile. Find and assign the parse nodes.
Note: local environments are not yet supported.
<<Commands: cmd beams pol density: TBP>>=
procedure :: compile => cmd_beams_pol_density_compile
<<Commands: sub interfaces>>=
module subroutine cmd_beams_pol_density_compile (cmd, global)
class(cmd_beams_pol_density_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_beams_pol_density_compile
<<Commands: procedures>>=
module subroutine cmd_beams_pol_density_compile (cmd, global)
class(cmd_beams_pol_density_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_pol_spec, pn_smatrix
integer :: i
pn_pol_spec => parse_node_get_sub_ptr (cmd%pn, 3)
call cmd%compile_options (global)
cmd%n_in = parse_node_get_n_sub (pn_pol_spec)
allocate (cmd%smatrix (cmd%n_in))
pn_smatrix => parse_node_get_sub_ptr (pn_pol_spec)
do i = 1, cmd%n_in
call cmd%smatrix(i)%compile (pn_smatrix)
pn_smatrix => parse_node_get_next_ptr (pn_smatrix)
end do
end subroutine cmd_beams_pol_density_compile
@ %def cmd_beams_pol_density_compile
@ Command execution: Fill polarization density matrices. No check
yet, the matrices are checked and normalized when the actual beam
object is created, just before integration. For intermediate storage,
we use the [[beam_structure]] object in the [[global]] data set.
<<Commands: cmd beams pol density: TBP>>=
procedure :: execute => cmd_beams_pol_density_execute
<<Commands: sub interfaces>>=
module subroutine cmd_beams_pol_density_execute (cmd, global)
class(cmd_beams_pol_density_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_beams_pol_density_execute
<<Commands: procedures>>=
module subroutine cmd_beams_pol_density_execute (cmd, global)
class(cmd_beams_pol_density_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(smatrix_t) :: smatrix
integer :: i
call global%beam_structure%init_pol (cmd%n_in)
do i = 1, cmd%n_in
call cmd%smatrix(i)%evaluate (smatrix, global)
call global%beam_structure%set_smatrix (i, smatrix)
end do
end subroutine cmd_beams_pol_density_execute
@ %def cmd_beams_pol_density_execute
@
\subsubsection{Beam polarization fraction}
In addition to the polarization density matrix, we can independently
specify the polarization fraction for one or both beams.
<<Commands: types>>=
type, extends (command_t) :: cmd_beams_pol_fraction_t
private
integer :: n_in = 0
type(parse_node_p), dimension(:), allocatable :: expr
contains
<<Commands: cmd beams pol fraction: TBP>>
end type cmd_beams_pol_fraction_t
@ %def cmd_beams_pol_fraction_t
@ Output.
<<Commands: cmd beams pol fraction: TBP>>=
procedure :: write => cmd_beams_pol_fraction_write
<<Commands: sub interfaces>>=
module subroutine cmd_beams_pol_fraction_write (cmd, unit, indent)
class(cmd_beams_pol_fraction_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_beams_pol_fraction_write
<<Commands: procedures>>=
module subroutine cmd_beams_pol_fraction_write (cmd, unit, indent)
class(cmd_beams_pol_fraction_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
select case (cmd%n_in)
case (1)
write (u, "(1x,A)") "beams polarization fraction: 1 [decay]"
case (2)
write (u, "(1x,A)") "beams polarization fraction: 2 [scattering]"
case default
write (u, "(1x,A)") "beams polarization fraction: [undefined]"
end select
end subroutine cmd_beams_pol_fraction_write
@ %def cmd_beams_pol_fraction_write
@ Compile. Find and assign the parse nodes.
Note: local environments are not yet supported.
<<Commands: cmd beams pol fraction: TBP>>=
procedure :: compile => cmd_beams_pol_fraction_compile
<<Commands: sub interfaces>>=
module subroutine cmd_beams_pol_fraction_compile (cmd, global)
class(cmd_beams_pol_fraction_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_beams_pol_fraction_compile
<<Commands: procedures>>=
module subroutine cmd_beams_pol_fraction_compile (cmd, global)
class(cmd_beams_pol_fraction_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_frac_spec, pn_expr
integer :: i
pn_frac_spec => parse_node_get_sub_ptr (cmd%pn, 3)
call cmd%compile_options (global)
cmd%n_in = parse_node_get_n_sub (pn_frac_spec)
allocate (cmd%expr (cmd%n_in))
pn_expr => parse_node_get_sub_ptr (pn_frac_spec)
do i = 1, cmd%n_in
cmd%expr(i)%ptr => pn_expr
pn_expr => parse_node_get_next_ptr (pn_expr)
end do
end subroutine cmd_beams_pol_fraction_compile
@ %def cmd_beams_pol_fraction_compile
@ Command execution: Retrieve the numerical values of the beam
polarization fractions. The results are stored in the
[[beam_structure]] component of the [[global]] data block.
<<Commands: cmd beams pol fraction: TBP>>=
procedure :: execute => cmd_beams_pol_fraction_execute
<<Commands: sub interfaces>>=
module subroutine cmd_beams_pol_fraction_execute (cmd, global)
class(cmd_beams_pol_fraction_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_beams_pol_fraction_execute
<<Commands: procedures>>=
module subroutine cmd_beams_pol_fraction_execute (cmd, global)
class(cmd_beams_pol_fraction_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
real(default), dimension(:), allocatable :: pol_f
type(eval_tree_t) :: expr
integer :: i
var_list => global%get_var_list_ptr ()
allocate (pol_f (cmd%n_in))
do i = 1, cmd%n_in
call expr%init_expr (cmd%expr(i)%ptr, var_list)
call expr%evaluate ()
if (expr%is_known ()) then
pol_f(i) = expr%get_real ()
else
call msg_fatal ("beams polarization fraction: undefined value")
end if
call expr%final ()
end do
call global%beam_structure%set_pol_f (pol_f)
end subroutine cmd_beams_pol_fraction_execute
@ %def cmd_beams_pol_fraction_execute
@
\subsubsection{Beam momentum}
This is completely analogous to the previous command, hence we can use
inheritance.
<<Commands: types>>=
type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_momentum_t
contains
<<Commands: cmd beams momentum: TBP>>
end type cmd_beams_momentum_t
@ %def cmd_beams_momentum_t
@ Output.
<<Commands: cmd beams momentum: TBP>>=
procedure :: write => cmd_beams_momentum_write
<<Commands: sub interfaces>>=
module subroutine cmd_beams_momentum_write (cmd, unit, indent)
class(cmd_beams_momentum_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_beams_momentum_write
<<Commands: procedures>>=
module subroutine cmd_beams_momentum_write (cmd, unit, indent)
class(cmd_beams_momentum_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
select case (cmd%n_in)
case (1)
write (u, "(1x,A)") "beams momentum: 1 [decay]"
case (2)
write (u, "(1x,A)") "beams momentum: 2 [scattering]"
case default
write (u, "(1x,A)") "beams momentum: [undefined]"
end select
end subroutine cmd_beams_momentum_write
@ %def cmd_beams_momentum_write
@ Compile: inherited.
Command execution: Not inherited, but just the error string and the final
command are changed.
<<Commands: cmd beams momentum: TBP>>=
procedure :: execute => cmd_beams_momentum_execute
<<Commands: sub interfaces>>=
module subroutine cmd_beams_momentum_execute (cmd, global)
class(cmd_beams_momentum_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_beams_momentum_execute
<<Commands: procedures>>=
module subroutine cmd_beams_momentum_execute (cmd, global)
class(cmd_beams_momentum_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
real(default), dimension(:), allocatable :: p
type(eval_tree_t) :: expr
integer :: i
var_list => global%get_var_list_ptr ()
allocate (p (cmd%n_in))
do i = 1, cmd%n_in
call expr%init_expr (cmd%expr(i)%ptr, var_list)
call expr%evaluate ()
if (expr%is_known ()) then
p(i) = expr%get_real ()
else
call msg_fatal ("beams momentum: undefined value")
end if
call expr%final ()
end do
call global%beam_structure%set_momentum (p)
end subroutine cmd_beams_momentum_execute
@ %def cmd_beams_momentum_execute
@
\subsubsection{Beam angles}
Again, this is analogous. There are two angles, polar angle $\theta$
and azimuthal angle $\phi$, which can be set independently for both beams.
<<Commands: types>>=
type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_theta_t
contains
<<Commands: cmd beams theta: TBP>>
end type cmd_beams_theta_t
type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_phi_t
contains
<<Commands: cmd beams phi: TBP>>
end type cmd_beams_phi_t
@ %def cmd_beams_theta_t
@ %def cmd_beams_phi_t
@ Output.
<<Commands: cmd beams theta: TBP>>=
procedure :: write => cmd_beams_theta_write
<<Commands: cmd beams phi: TBP>>=
procedure :: write => cmd_beams_phi_write
<<Commands: sub interfaces>>=
module subroutine cmd_beams_theta_write (cmd, unit, indent)
class(cmd_beams_theta_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_beams_theta_write
module subroutine cmd_beams_phi_write (cmd, unit, indent)
class(cmd_beams_phi_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_beams_phi_write
<<Commands: procedures>>=
module subroutine cmd_beams_theta_write (cmd, unit, indent)
class(cmd_beams_theta_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
select case (cmd%n_in)
case (1)
write (u, "(1x,A)") "beams theta: 1 [decay]"
case (2)
write (u, "(1x,A)") "beams theta: 2 [scattering]"
case default
write (u, "(1x,A)") "beams theta: [undefined]"
end select
end subroutine cmd_beams_theta_write
module subroutine cmd_beams_phi_write (cmd, unit, indent)
class(cmd_beams_phi_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
select case (cmd%n_in)
case (1)
write (u, "(1x,A)") "beams phi: 1 [decay]"
case (2)
write (u, "(1x,A)") "beams phi: 2 [scattering]"
case default
write (u, "(1x,A)") "beams phi: [undefined]"
end select
end subroutine cmd_beams_phi_write
@ %def cmd_beams_theta_write
@ %def cmd_beams_phi_write
@ Compile: inherited.
Command execution: Not inherited, but just the error string and the final
command are changed.
<<Commands: cmd beams theta: TBP>>=
procedure :: execute => cmd_beams_theta_execute
<<Commands: cmd beams phi: TBP>>=
procedure :: execute => cmd_beams_phi_execute
<<Commands: sub interfaces>>=
module subroutine cmd_beams_theta_execute (cmd, global)
class(cmd_beams_theta_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_beams_theta_execute
module subroutine cmd_beams_phi_execute (cmd, global)
class(cmd_beams_phi_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_beams_phi_execute
<<Commands: procedures>>=
module subroutine cmd_beams_theta_execute (cmd, global)
class(cmd_beams_theta_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
real(default), dimension(:), allocatable :: theta
type(eval_tree_t) :: expr
integer :: i
var_list => global%get_var_list_ptr ()
allocate (theta (cmd%n_in))
do i = 1, cmd%n_in
call expr%init_expr (cmd%expr(i)%ptr, var_list)
call expr%evaluate ()
if (expr%is_known ()) then
theta(i) = expr%get_real ()
else
call msg_fatal ("beams theta: undefined value")
end if
call expr%final ()
end do
call global%beam_structure%set_theta (theta)
end subroutine cmd_beams_theta_execute
module subroutine cmd_beams_phi_execute (cmd, global)
class(cmd_beams_phi_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
real(default), dimension(:), allocatable :: phi
type(eval_tree_t) :: expr
integer :: i
var_list => global%get_var_list_ptr ()
allocate (phi (cmd%n_in))
do i = 1, cmd%n_in
call expr%init_expr (cmd%expr(i)%ptr, var_list)
call expr%evaluate ()
if (expr%is_known ()) then
phi(i) = expr%get_real ()
else
call msg_fatal ("beams phi: undefined value")
end if
call expr%final ()
end do
call global%beam_structure%set_phi (phi)
end subroutine cmd_beams_phi_execute
@ %def cmd_beams_theta_execute
@ %def cmd_beams_phi_execute
@
\subsubsection{Cuts}
Define a cut expression. We store the parse tree for the right-hand
side instead of compiling it. Compilation is deferred to the process
environment where the cut expression is used.
<<Commands: types>>=
type, extends (command_t) :: cmd_cuts_t
private
type(parse_node_t), pointer :: pn_lexpr => null ()
contains
<<Commands: cmd cuts: TBP>>
end type cmd_cuts_t
@ %def cmd_cuts_t
@ Output. Do not print the parse tree, since this may get cluttered.
Just a message that cuts have been defined.
<<Commands: cmd cuts: TBP>>=
procedure :: write => cmd_cuts_write
<<Commands: sub interfaces>>=
module subroutine cmd_cuts_write (cmd, unit, indent)
class(cmd_cuts_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_cuts_write
<<Commands: procedures>>=
module subroutine cmd_cuts_write (cmd, unit, indent)
class(cmd_cuts_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)") "cuts: [defined]"
end subroutine cmd_cuts_write
@ %def cmd_cuts_write
@ Compile. Simply store the parse (sub)tree.
<<Commands: cmd cuts: TBP>>=
procedure :: compile => cmd_cuts_compile
<<Commands: sub interfaces>>=
module subroutine cmd_cuts_compile (cmd, global)
class(cmd_cuts_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_cuts_compile
<<Commands: procedures>>=
module subroutine cmd_cuts_compile (cmd, global)
class(cmd_cuts_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
cmd%pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 3)
end subroutine cmd_cuts_compile
@ %def cmd_cuts_compile
@ Instead of evaluating the cut expression, link the parse tree to the
global data set, such that it is compiled and executed in the
appropriate process context.
<<Commands: cmd cuts: TBP>>=
procedure :: execute => cmd_cuts_execute
<<Commands: sub interfaces>>=
module subroutine cmd_cuts_execute (cmd, global)
class(cmd_cuts_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_cuts_execute
<<Commands: procedures>>=
module subroutine cmd_cuts_execute (cmd, global)
class(cmd_cuts_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
global%pn%cuts_lexpr => cmd%pn_lexpr
end subroutine cmd_cuts_execute
@ %def cmd_cuts_execute
@
\subsubsection{General, Factorization and Renormalization Scales}
Define a scale expression for either the renormalization or the
factorization scale. We store the parse tree for the right-hand
side instead of compiling it. Compilation is deferred to the process
environment where the expression is used.
<<Commands: types>>=
type, extends (command_t) :: cmd_scale_t
private
type(parse_node_t), pointer :: pn_expr => null ()
contains
<<Commands: cmd scale: TBP>>
end type cmd_scale_t
@ %def cmd_scale_t
<<Commands: types>>=
type, extends (command_t) :: cmd_fac_scale_t
private
type(parse_node_t), pointer :: pn_expr => null ()
contains
<<Commands: cmd fac scale: TBP>>
end type cmd_fac_scale_t
@ %def cmd_fac_scale_t
<<Commands: types>>=
type, extends (command_t) :: cmd_ren_scale_t
private
type(parse_node_t), pointer :: pn_expr => null ()
contains
<<Commands: cmd ren scale: TBP>>
end type cmd_ren_scale_t
@ %def cmd_ren_scale_t
@ Output. Do not print the parse tree, since this may get cluttered.
Just a message that scale, renormalization and factorization have been
defined, respectively.
<<Commands: cmd scale: TBP>>=
procedure :: write => cmd_scale_write
<<Commands: sub interfaces>>=
module subroutine cmd_scale_write (cmd, unit, indent)
class(cmd_scale_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_scale_write
<<Commands: procedures>>=
module subroutine cmd_scale_write (cmd, unit, indent)
class(cmd_scale_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)") "scale: [defined]"
end subroutine cmd_scale_write
@ %def cmd_scale_write
@
<<Commands: cmd fac scale: TBP>>=
procedure :: write => cmd_fac_scale_write
<<Commands: sub interfaces>>=
module subroutine cmd_fac_scale_write (cmd, unit, indent)
class(cmd_fac_scale_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_fac_scale_write
<<Commands: procedures>>=
module subroutine cmd_fac_scale_write (cmd, unit, indent)
class(cmd_fac_scale_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)") "factorization scale: [defined]"
end subroutine cmd_fac_scale_write
@ %def cmd_fac_scale_write
@
<<Commands: cmd ren scale: TBP>>=
procedure :: write => cmd_ren_scale_write
<<Commands: sub interfaces>>=
module subroutine cmd_ren_scale_write (cmd, unit, indent)
class(cmd_ren_scale_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_ren_scale_write
<<Commands: procedures>>=
module subroutine cmd_ren_scale_write (cmd, unit, indent)
class(cmd_ren_scale_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)") "renormalization scale: [defined]"
end subroutine cmd_ren_scale_write
@ %def cmd_ren_scale_write
@ Compile. Simply store the parse (sub)tree.
<<Commands: cmd scale: TBP>>=
procedure :: compile => cmd_scale_compile
<<Commands: sub interfaces>>=
module subroutine cmd_scale_compile (cmd, global)
class(cmd_scale_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_scale_compile
<<Commands: procedures>>=
module subroutine cmd_scale_compile (cmd, global)
class(cmd_scale_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
end subroutine cmd_scale_compile
@ %def cmd_scale_compile
@
<<Commands: cmd fac scale: TBP>>=
procedure :: compile => cmd_fac_scale_compile
<<Commands: sub interfaces>>=
module subroutine cmd_fac_scale_compile (cmd, global)
class(cmd_fac_scale_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_fac_scale_compile
<<Commands: procedures>>=
module subroutine cmd_fac_scale_compile (cmd, global)
class(cmd_fac_scale_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
end subroutine cmd_fac_scale_compile
@ %def cmd_fac_scale_compile
@
<<Commands: cmd ren scale: TBP>>=
procedure :: compile => cmd_ren_scale_compile
<<Commands: sub interfaces>>=
module subroutine cmd_ren_scale_compile (cmd, global)
class(cmd_ren_scale_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_ren_scale_compile
<<Commands: procedures>>=
module subroutine cmd_ren_scale_compile (cmd, global)
class(cmd_ren_scale_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
end subroutine cmd_ren_scale_compile
@ %def cmd_ren_scale_compile
@ Instead of evaluating the scale expression, link the parse tree to the
global data set, such that it is compiled and executed in the
appropriate process context.
<<Commands: cmd scale: TBP>>=
procedure :: execute => cmd_scale_execute
<<Commands: sub interfaces>>=
module subroutine cmd_scale_execute (cmd, global)
class(cmd_scale_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_scale_execute
<<Commands: procedures>>=
module subroutine cmd_scale_execute (cmd, global)
class(cmd_scale_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
global%pn%scale_expr => cmd%pn_expr
end subroutine cmd_scale_execute
@ %def cmd_scale_execute
@
<<Commands: cmd fac scale: TBP>>=
procedure :: execute => cmd_fac_scale_execute
<<Commands: sub interfaces>>=
module subroutine cmd_fac_scale_execute (cmd, global)
class(cmd_fac_scale_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_fac_scale_execute
<<Commands: procedures>>=
module subroutine cmd_fac_scale_execute (cmd, global)
class(cmd_fac_scale_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
global%pn%fac_scale_expr => cmd%pn_expr
end subroutine cmd_fac_scale_execute
@ %def cmd_fac_scale_execute
@
<<Commands: cmd ren scale: TBP>>=
procedure :: execute => cmd_ren_scale_execute
<<Commands: sub interfaces>>=
module subroutine cmd_ren_scale_execute (cmd, global)
class(cmd_ren_scale_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_ren_scale_execute
<<Commands: procedures>>=
module subroutine cmd_ren_scale_execute (cmd, global)
class(cmd_ren_scale_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
global%pn%ren_scale_expr => cmd%pn_expr
end subroutine cmd_ren_scale_execute
@ %def cmd_ren_scale_execute
@
\subsubsection{Weight}
Define a weight expression. The weight is applied to a process to be
integrated, event by event. We store the parse tree for the right-hand
side instead of compiling it. Compilation is deferred to the process
environment where the expression is used.
<<Commands: types>>=
type, extends (command_t) :: cmd_weight_t
private
type(parse_node_t), pointer :: pn_expr => null ()
contains
<<Commands: cmd weight: TBP>>
end type cmd_weight_t
@ %def cmd_weight_t
@ Output. Do not print the parse tree, since this may get cluttered.
Just a message that scale, renormalization and factorization have been
defined, respectively.
<<Commands: cmd weight: TBP>>=
procedure :: write => cmd_weight_write
<<Commands: sub interfaces>>=
module subroutine cmd_weight_write (cmd, unit, indent)
class(cmd_weight_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_weight_write
<<Commands: procedures>>=
module subroutine cmd_weight_write (cmd, unit, indent)
class(cmd_weight_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)") "weight expression: [defined]"
end subroutine cmd_weight_write
@ %def cmd_weight_write
@ Compile. Simply store the parse (sub)tree.
<<Commands: cmd weight: TBP>>=
procedure :: compile => cmd_weight_compile
<<Commands: sub interfaces>>=
module subroutine cmd_weight_compile (cmd, global)
class(cmd_weight_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_weight_compile
<<Commands: procedures>>=
module subroutine cmd_weight_compile (cmd, global)
class(cmd_weight_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
end subroutine cmd_weight_compile
@ %def cmd_weight_compile
@ Instead of evaluating the expression, link the parse tree to the
global data set, such that it is compiled and executed in the
appropriate process context.
<<Commands: cmd weight: TBP>>=
procedure :: execute => cmd_weight_execute
<<Commands: sub interfaces>>=
module subroutine cmd_weight_execute (cmd, global)
class(cmd_weight_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_weight_execute
<<Commands: procedures>>=
module subroutine cmd_weight_execute (cmd, global)
class(cmd_weight_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
global%pn%weight_expr => cmd%pn_expr
end subroutine cmd_weight_execute
@ %def cmd_weight_execute
@
\subsubsection{Selection}
Define a selection expression. This is to be applied upon simulation or
event-file rescanning, event by event. We store the parse tree for the
right-hand side instead of compiling it. Compilation is deferred to the
environment where the expression is used.
<<Commands: types>>=
type, extends (command_t) :: cmd_selection_t
private
type(parse_node_t), pointer :: pn_expr => null ()
contains
<<Commands: cmd selection: TBP>>
end type cmd_selection_t
@ %def cmd_selection_t
@ Output. Do not print the parse tree, since this may get cluttered.
Just a message that scale, renormalization and factorization have been
defined, respectively.
<<Commands: cmd selection: TBP>>=
procedure :: write => cmd_selection_write
<<Commands: sub interfaces>>=
module subroutine cmd_selection_write (cmd, unit, indent)
class(cmd_selection_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_selection_write
<<Commands: procedures>>=
module subroutine cmd_selection_write (cmd, unit, indent)
class(cmd_selection_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)") "selection expression: [defined]"
end subroutine cmd_selection_write
@ %def cmd_selection_write
@ Compile. Simply store the parse (sub)tree.
<<Commands: cmd selection: TBP>>=
procedure :: compile => cmd_selection_compile
<<Commands: sub interfaces>>=
module subroutine cmd_selection_compile (cmd, global)
class(cmd_selection_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_selection_compile
<<Commands: procedures>>=
module subroutine cmd_selection_compile (cmd, global)
class(cmd_selection_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
end subroutine cmd_selection_compile
@ %def cmd_selection_compile
@ Instead of evaluating the expression, link the parse tree to the
global data set, such that it is compiled and executed in the
appropriate process context.
<<Commands: cmd selection: TBP>>=
procedure :: execute => cmd_selection_execute
<<Commands: sub interfaces>>=
module subroutine cmd_selection_execute (cmd, global)
class(cmd_selection_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_selection_execute
<<Commands: procedures>>=
module subroutine cmd_selection_execute (cmd, global)
class(cmd_selection_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
global%pn%selection_lexpr => cmd%pn_expr
end subroutine cmd_selection_execute
@ %def cmd_selection_execute
@
\subsubsection{Reweight}
Define a reweight expression. This is to be applied upon simulation or
event-file rescanning, event by event. We store the parse tree for the
right-hand side instead of compiling it. Compilation is deferred to the
environment where the expression is used.
<<Commands: types>>=
type, extends (command_t) :: cmd_reweight_t
private
type(parse_node_t), pointer :: pn_expr => null ()
contains
<<Commands: cmd reweight: TBP>>
end type cmd_reweight_t
@ %def cmd_reweight_t
@ Output. Do not print the parse tree, since this may get cluttered.
Just a message that scale, renormalization and factorization have been
defined, respectively.
<<Commands: cmd reweight: TBP>>=
procedure :: write => cmd_reweight_write
<<Commands: sub interfaces>>=
module subroutine cmd_reweight_write (cmd, unit, indent)
class(cmd_reweight_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_reweight_write
<<Commands: procedures>>=
module subroutine cmd_reweight_write (cmd, unit, indent)
class(cmd_reweight_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)") "reweight expression: [defined]"
end subroutine cmd_reweight_write
@ %def cmd_reweight_write
@ Compile. Simply store the parse (sub)tree.
<<Commands: cmd reweight: TBP>>=
procedure :: compile => cmd_reweight_compile
<<Commands: sub interfaces>>=
module subroutine cmd_reweight_compile (cmd, global)
class(cmd_reweight_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_reweight_compile
<<Commands: procedures>>=
module subroutine cmd_reweight_compile (cmd, global)
class(cmd_reweight_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
end subroutine cmd_reweight_compile
@ %def cmd_reweight_compile
@ Instead of evaluating the expression, link the parse tree to the
global data set, such that it is compiled and executed in the
appropriate process context.
<<Commands: cmd reweight: TBP>>=
procedure :: execute => cmd_reweight_execute
<<Commands: sub interfaces>>=
module subroutine cmd_reweight_execute (cmd, global)
class(cmd_reweight_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_reweight_execute
<<Commands: procedures>>=
module subroutine cmd_reweight_execute (cmd, global)
class(cmd_reweight_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
global%pn%reweight_expr => cmd%pn_expr
end subroutine cmd_reweight_execute
@ %def cmd_reweight_execute
@
\subsubsection{Alternative Simulation Setups}
Together with simulation, we can re-evaluate event weights in the context of
alternative setups. The [[cmd_alt_setup_t]] object is designed to hold these
setups, which are brace-enclosed command lists. Compilation is deferred to
the simulation environment where the setup expression is used.
<<Commands: types>>=
type, extends (command_t) :: cmd_alt_setup_t
private
type(parse_node_p), dimension(:), allocatable :: setup
contains
<<Commands: cmd alt setup: TBP>>
end type cmd_alt_setup_t
@ %def cmd_alt_setup_t
@ Output. Print just a message that the alternative setup list has been
defined.
<<Commands: cmd alt setup: TBP>>=
procedure :: write => cmd_alt_setup_write
<<Commands: sub interfaces>>=
module subroutine cmd_alt_setup_write (cmd, unit, indent)
class(cmd_alt_setup_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_alt_setup_write
<<Commands: procedures>>=
module subroutine cmd_alt_setup_write (cmd, unit, indent)
class(cmd_alt_setup_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,I0,A)") "alt_setup: ", size (cmd%setup), " entries"
end subroutine cmd_alt_setup_write
@ %def cmd_alt_setup_write
@ Compile. Store the parse sub-trees in an array.
<<Commands: cmd alt setup: TBP>>=
procedure :: compile => cmd_alt_setup_compile
<<Commands: sub interfaces>>=
module subroutine cmd_alt_setup_compile (cmd, global)
class(cmd_alt_setup_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_alt_setup_compile
<<Commands: procedures>>=
module subroutine cmd_alt_setup_compile (cmd, global)
class(cmd_alt_setup_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_list, pn_setup
integer :: i
pn_list => parse_node_get_sub_ptr (cmd%pn, 3)
if (associated (pn_list)) then
allocate (cmd%setup (parse_node_get_n_sub (pn_list)))
i = 1
pn_setup => parse_node_get_sub_ptr (pn_list)
do while (associated (pn_setup))
cmd%setup(i)%ptr => pn_setup
i = i + 1
pn_setup => parse_node_get_next_ptr (pn_setup)
end do
else
allocate (cmd%setup (0))
end if
end subroutine cmd_alt_setup_compile
@ %def cmd_alt_setup_compile
@ Execute. Transfer the array of command lists to the global environment.
<<Commands: cmd alt setup: TBP>>=
procedure :: execute => cmd_alt_setup_execute
<<Commands: sub interfaces>>=
module subroutine cmd_alt_setup_execute (cmd, global)
class(cmd_alt_setup_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_alt_setup_execute
<<Commands: procedures>>=
module subroutine cmd_alt_setup_execute (cmd, global)
class(cmd_alt_setup_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
if (allocated (global%pn%alt_setup)) deallocate (global%pn%alt_setup)
allocate (global%pn%alt_setup (size (cmd%setup)))
global%pn%alt_setup = cmd%setup
end subroutine cmd_alt_setup_execute
@ %def cmd_alt_setup_execute
@
\subsubsection{Integration}
Integrate several processes, consecutively with identical parameters.
<<Commands: types>>=
type, extends (command_t) :: cmd_integrate_t
private
integer :: n_proc = 0
type(string_t), dimension(:), allocatable :: process_id
contains
<<Commands: cmd integrate: TBP>>
end type cmd_integrate_t
@ %def cmd_integrate_t
@ Output: we know the process IDs.
<<Commands: cmd integrate: TBP>>=
procedure :: write => cmd_integrate_write
<<Commands: sub interfaces>>=
module subroutine cmd_integrate_write (cmd, unit, indent)
class(cmd_integrate_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_integrate_write
<<Commands: procedures>>=
module subroutine cmd_integrate_write (cmd, unit, indent)
class(cmd_integrate_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)", advance="no") "integrate ("
do i = 1, cmd%n_proc
if (i > 1) write (u, "(A,1x)", advance="no") ","
write (u, "(A)", advance="no") char (cmd%process_id(i))
end do
write (u, "(A)") ")"
end subroutine cmd_integrate_write
@ %def cmd_integrate_write
@ Compile.
<<Commands: cmd integrate: TBP>>=
procedure :: compile => cmd_integrate_compile
<<Commands: sub interfaces>>=
module subroutine cmd_integrate_compile (cmd, global)
class(cmd_integrate_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_integrate_compile
<<Commands: procedures>>=
module subroutine cmd_integrate_compile (cmd, global)
class(cmd_integrate_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_proclist, pn_proc
integer :: i
pn_proclist => parse_node_get_sub_ptr (cmd%pn, 2)
cmd%pn_opt => parse_node_get_next_ptr (pn_proclist)
call cmd%compile_options (global)
cmd%n_proc = parse_node_get_n_sub (pn_proclist)
allocate (cmd%process_id (cmd%n_proc))
pn_proc => parse_node_get_sub_ptr (pn_proclist)
do i = 1, cmd%n_proc
cmd%process_id(i) = parse_node_get_string (pn_proc)
call global%process_stack%init_result_vars (cmd%process_id(i))
pn_proc => parse_node_get_next_ptr (pn_proc)
end do
end subroutine cmd_integrate_compile
@ %def cmd_integrate_compile
@ Command execution. Integrate the process(es) with the predefined number
of passes, iterations and calls. For structure functions, cuts,
weight and scale, use local definitions if present; by default, the local
definitions are initialized with the global ones.
The [[integrate]] procedure should take its input from the currently
active local environment, but produce a process record in the stack of
the global environment.
Since the process acquires a snapshot of the variable list, so if the global
list (or the local one) is deleted, this does no harm. This implies that
later changes of the variable list do not affect the stored process.
<<Commands: cmd integrate: TBP>>=
procedure :: execute => cmd_integrate_execute
<<Commands: sub interfaces>>=
module subroutine cmd_integrate_execute (cmd, global)
class(cmd_integrate_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_integrate_execute
<<Commands: procedures>>=
module subroutine cmd_integrate_execute (cmd, global)
class(cmd_integrate_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
integer :: i
if (debug_on) call msg_debug (D_CORE, "cmd_integrate_execute")
do i = 1, cmd%n_proc
if (debug_on) call msg_debug &
(D_CORE, "cmd%process_id(i) ", cmd%process_id(i))
call integrate_process (cmd%process_id(i), cmd%local, global)
call global%process_stack%fill_result_vars (cmd%process_id(i))
call global%process_stack%update_result_vars &
(cmd%process_id(i), global%var_list)
if (signal_is_pending ()) return
end do
end subroutine cmd_integrate_execute
@ %def cmd_integrate_execute
@
\subsubsection{Observables}
Declare an observable. After the declaration, it can be used to
record data, and at the end one can retrieve average and error.
<<Commands: types>>=
type, extends (command_t) :: cmd_observable_t
private
type(string_t) :: id
contains
<<Commands: cmd observable: TBP>>
end type cmd_observable_t
@ %def cmd_observable_t
@ Output. We know the ID.
<<Commands: cmd observable: TBP>>=
procedure :: write => cmd_observable_write
<<Commands: sub interfaces>>=
module subroutine cmd_observable_write (cmd, unit, indent)
class(cmd_observable_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_observable_write
<<Commands: procedures>>=
module subroutine cmd_observable_write (cmd, unit, indent)
class(cmd_observable_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,A)") "observable: ", char (cmd%id)
end subroutine cmd_observable_write
@ %def cmd_observable_write
@ Compile. Just record the observable ID.
<<Commands: cmd observable: TBP>>=
procedure :: compile => cmd_observable_compile
<<Commands: sub interfaces>>=
module subroutine cmd_observable_compile (cmd, global)
class(cmd_observable_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_observable_compile
<<Commands: procedures>>=
module subroutine cmd_observable_compile (cmd, global)
class(cmd_observable_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_tag
pn_tag => parse_node_get_sub_ptr (cmd%pn, 2)
if (associated (pn_tag)) then
cmd%pn_opt => parse_node_get_next_ptr (pn_tag)
end if
call cmd%compile_options (global)
select case (char (parse_node_get_rule_key (pn_tag)))
case ("analysis_id")
cmd%id = parse_node_get_string (pn_tag)
case default
call msg_bug ("observable: name expression not implemented (yet)")
end select
end subroutine cmd_observable_compile
@ %def cmd_observable_compile
@ Command execution. This declares the observable and allocates it in
the analysis store.
<<Commands: cmd observable: TBP>>=
procedure :: execute => cmd_observable_execute
<<Commands: sub interfaces>>=
module subroutine cmd_observable_execute (cmd, global)
class(cmd_observable_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_observable_execute
<<Commands: procedures>>=
module subroutine cmd_observable_execute (cmd, global)
class(cmd_observable_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
type(graph_options_t) :: graph_options
type(string_t) :: label, unit
var_list => cmd%local%get_var_list_ptr ()
label = var_list%get_sval (var_str ("$obs_label"))
unit = var_list%get_sval (var_str ("$obs_unit"))
call graph_options%init ()
call set_graph_options (graph_options, var_list)
call analysis_init_observable (cmd%id, label, unit, graph_options)
end subroutine cmd_observable_execute
@ %def cmd_observable_execute
@
\subsubsection{Histograms}
Declare a histogram. At minimum, we have to set lower and upper bound
and bin width.
<<Commands: types>>=
type, extends (command_t) :: cmd_histogram_t
private
type(string_t) :: id
type(parse_node_t), pointer :: pn_lower_bound => null ()
type(parse_node_t), pointer :: pn_upper_bound => null ()
type(parse_node_t), pointer :: pn_bin_width => null ()
contains
<<Commands: cmd histogram: TBP>>
end type cmd_histogram_t
@ %def cmd_histogram_t
@ Output. Just print the ID.
<<Commands: cmd histogram: TBP>>=
procedure :: write => cmd_histogram_write
<<Commands: sub interfaces>>=
module subroutine cmd_histogram_write (cmd, unit, indent)
class(cmd_histogram_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_histogram_write
<<Commands: procedures>>=
module subroutine cmd_histogram_write (cmd, unit, indent)
class(cmd_histogram_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,A)") "histogram: ", char (cmd%id)
end subroutine cmd_histogram_write
@ %def cmd_histogram_write
@ Compile. Record the histogram ID and initialize lower, upper bound
and bin width.
<<Commands: cmd histogram: TBP>>=
procedure :: compile => cmd_histogram_compile
<<Commands: sub interfaces>>=
module subroutine cmd_histogram_compile (cmd, global)
class(cmd_histogram_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_histogram_compile
<<Commands: procedures>>=
module subroutine cmd_histogram_compile (cmd, global)
class(cmd_histogram_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_tag, pn_args, pn_arg1, pn_arg2, pn_arg3
character(*), parameter :: e_illegal_use = &
"illegal usage of 'histogram': insufficient number of arguments"
pn_tag => parse_node_get_sub_ptr (cmd%pn, 2)
pn_args => parse_node_get_next_ptr (pn_tag)
if (associated (pn_args)) then
pn_arg1 => parse_node_get_sub_ptr (pn_args)
if (.not. associated (pn_arg1)) call msg_fatal (e_illegal_use)
pn_arg2 => parse_node_get_next_ptr (pn_arg1)
if (.not. associated (pn_arg2)) call msg_fatal (e_illegal_use)
pn_arg3 => parse_node_get_next_ptr (pn_arg2)
cmd%pn_opt => parse_node_get_next_ptr (pn_args)
end if
call cmd%compile_options (global)
select case (char (parse_node_get_rule_key (pn_tag)))
case ("analysis_id")
cmd%id = parse_node_get_string (pn_tag)
case default
call msg_bug ("histogram: name expression not implemented (yet)")
end select
cmd%pn_lower_bound => pn_arg1
cmd%pn_upper_bound => pn_arg2
cmd%pn_bin_width => pn_arg3
end subroutine cmd_histogram_compile
@ %def cmd_histogram_compile
@ Command execution. This declares the histogram and allocates it in
the analysis store.
<<Commands: cmd histogram: TBP>>=
procedure :: execute => cmd_histogram_execute
<<Commands: sub interfaces>>=
module subroutine cmd_histogram_execute (cmd, global)
class(cmd_histogram_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_histogram_execute
<<Commands: procedures>>=
module subroutine cmd_histogram_execute (cmd, global)
class(cmd_histogram_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
real(default) :: lower_bound, upper_bound, bin_width
integer :: bin_number
logical :: bin_width_is_used, normalize_bins
type(string_t) :: obs_label, obs_unit
type(graph_options_t) :: graph_options
type(drawing_options_t) :: drawing_options
var_list => cmd%local%get_var_list_ptr ()
lower_bound = eval_real (cmd%pn_lower_bound, var_list)
upper_bound = eval_real (cmd%pn_upper_bound, var_list)
if (associated (cmd%pn_bin_width)) then
bin_width = eval_real (cmd%pn_bin_width, var_list)
bin_width_is_used = .true.
else if (var_list%is_known (var_str ("n_bins"))) then
bin_number = &
var_list%get_ival (var_str ("n_bins"))
bin_width_is_used = .false.
else
call msg_error ("Cmd '" // char (cmd%id) // &
"': neither bin width nor number is defined")
end if
normalize_bins = &
var_list%get_lval (var_str ("?normalize_bins"))
obs_label = &
var_list%get_sval (var_str ("$obs_label"))
obs_unit = &
var_list%get_sval (var_str ("$obs_unit"))
call graph_options%init ()
call set_graph_options (graph_options, var_list)
call drawing_options%init_histogram ()
call set_drawing_options (drawing_options, var_list)
if (bin_width_is_used) then
call analysis_init_histogram &
(cmd%id, lower_bound, upper_bound, bin_width, &
normalize_bins, &
obs_label, obs_unit, &
graph_options, drawing_options)
else
call analysis_init_histogram &
(cmd%id, lower_bound, upper_bound, bin_number, &
normalize_bins, &
obs_label, obs_unit, &
graph_options, drawing_options)
end if
end subroutine cmd_histogram_execute
@ %def cmd_histogram_execute
@ Set the graph options from a variable list.
<<Commands: procedures>>=
subroutine set_graph_options (gro, var_list)
type(graph_options_t), intent(inout) :: gro
type(var_list_t), intent(in) :: var_list
call gro%set (title = var_list%get_sval (var_str ("$title")))
call gro%set (description = var_list%get_sval (var_str ("$description")))
call gro%set (x_label = var_list%get_sval (var_str ("$x_label")))
call gro%set (y_label = var_list%get_sval (var_str ("$y_label")))
call gro%set (width_mm = var_list%get_ival (var_str ("graph_width_mm")))
call gro%set (height_mm = var_list%get_ival (var_str ("graph_height_mm")))
call gro%set (x_log = var_list%get_lval (var_str ("?x_log")))
call gro%set (y_log = var_list%get_lval (var_str ("?y_log")))
if (var_list%is_known (var_str ("x_min"))) &
call gro%set (x_min = var_list%get_rval (var_str ("x_min")))
if (var_list%is_known (var_str ("x_max"))) &
call gro%set (x_max = var_list%get_rval (var_str ("x_max")))
if (var_list%is_known (var_str ("y_min"))) &
call gro%set (y_min = var_list%get_rval (var_str ("y_min")))
if (var_list%is_known (var_str ("y_max"))) &
call gro%set (y_max = var_list%get_rval (var_str ("y_max")))
call gro%set (gmlcode_bg = var_list%get_sval (var_str ("$gmlcode_bg")))
call gro%set (gmlcode_fg = var_list%get_sval (var_str ("$gmlcode_fg")))
end subroutine set_graph_options
@ %def set_graph_options
@ Set the drawing options from a variable list.
<<Commands: procedures>>=
subroutine set_drawing_options (dro, var_list)
type(drawing_options_t), intent(inout) :: dro
type(var_list_t), intent(in) :: var_list
if (var_list%is_known (var_str ("?draw_histogram"))) then
if (var_list%get_lval (var_str ("?draw_histogram"))) then
call dro%set (with_hbars = .true.)
else
call dro%set (with_hbars = .false., &
with_base = .false., fill = .false., piecewise = .false.)
end if
end if
if (var_list%is_known (var_str ("?draw_base"))) then
if (var_list%get_lval (var_str ("?draw_base"))) then
call dro%set (with_base = .true.)
else
call dro%set (with_base = .false., fill = .false.)
end if
end if
if (var_list%is_known (var_str ("?draw_piecewise"))) then
if (var_list%get_lval (var_str ("?draw_piecewise"))) then
call dro%set (piecewise = .true.)
else
call dro%set (piecewise = .false.)
end if
end if
if (var_list%is_known (var_str ("?fill_curve"))) then
if (var_list%get_lval (var_str ("?fill_curve"))) then
call dro%set (fill = .true., with_base = .true.)
else
call dro%set (fill = .false.)
end if
end if
if (var_list%is_known (var_str ("?draw_curve"))) then
if (var_list%get_lval (var_str ("?draw_curve"))) then
call dro%set (draw = .true.)
else
call dro%set (draw = .false.)
end if
end if
if (var_list%is_known (var_str ("?draw_errors"))) then
if (var_list%get_lval (var_str ("?draw_errors"))) then
call dro%set (err = .true.)
else
call dro%set (err = .false.)
end if
end if
if (var_list%is_known (var_str ("?draw_symbols"))) then
if (var_list%get_lval (var_str ("?draw_symbols"))) then
call dro%set (symbols = .true.)
else
call dro%set (symbols = .false.)
end if
end if
if (var_list%is_known (var_str ("$fill_options"))) then
call dro%set (fill_options = &
var_list%get_sval (var_str ("$fill_options")))
end if
if (var_list%is_known (var_str ("$draw_options"))) then
call dro%set (draw_options = &
var_list%get_sval (var_str ("$draw_options")))
end if
if (var_list%is_known (var_str ("$err_options"))) then
call dro%set (err_options = &
var_list%get_sval (var_str ("$err_options")))
end if
if (var_list%is_known (var_str ("$symbol"))) then
call dro%set (symbol = &
var_list%get_sval (var_str ("$symbol")))
end if
if (var_list%is_known (var_str ("$gmlcode_bg"))) then
call dro%set (gmlcode_bg = &
var_list%get_sval (var_str ("$gmlcode_bg")))
end if
if (var_list%is_known (var_str ("$gmlcode_fg"))) then
call dro%set (gmlcode_fg = &
var_list%get_sval (var_str ("$gmlcode_fg")))
end if
end subroutine set_drawing_options
@ %def set_drawing_options
@
\subsubsection{Plots}
Declare a plot. No mandatory arguments, just options.
<<Commands: types>>=
type, extends (command_t) :: cmd_plot_t
private
type(string_t) :: id
contains
<<Commands: cmd plot: TBP>>
end type cmd_plot_t
@ %def cmd_plot_t
@ Output. Just print the ID.
<<Commands: cmd plot: TBP>>=
procedure :: write => cmd_plot_write
<<Commands: sub interfaces>>=
module subroutine cmd_plot_write (cmd, unit, indent)
class(cmd_plot_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_plot_write
<<Commands: procedures>>=
module subroutine cmd_plot_write (cmd, unit, indent)
class(cmd_plot_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,A)") "plot: ", char (cmd%id)
end subroutine cmd_plot_write
@ %def cmd_plot_write
@ Compile. Record the plot ID and initialize lower, upper bound
and bin width.
<<Commands: cmd plot: TBP>>=
procedure :: compile => cmd_plot_compile
<<Commands: sub interfaces>>=
module subroutine cmd_plot_compile (cmd, global)
class(cmd_plot_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_plot_compile
<<Commands: procedures>>=
module subroutine cmd_plot_compile (cmd, global)
class(cmd_plot_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_tag
pn_tag => parse_node_get_sub_ptr (cmd%pn, 2)
cmd%pn_opt => parse_node_get_next_ptr (pn_tag)
call cmd%init (pn_tag, global)
end subroutine cmd_plot_compile
@ %def cmd_plot_compile
@ This init routine is separated because it is reused below for graph
initialization.
<<Commands: cmd plot: TBP>>=
procedure :: init => cmd_plot_init
<<Commands: sub interfaces>>=
module subroutine cmd_plot_init (plot, pn_tag, global)
class(cmd_plot_t), intent(inout) :: plot
type(parse_node_t), intent(in), pointer :: pn_tag
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_plot_init
<<Commands: procedures>>=
module subroutine cmd_plot_init (plot, pn_tag, global)
class(cmd_plot_t), intent(inout) :: plot
type(parse_node_t), intent(in), pointer :: pn_tag
type(rt_data_t), intent(inout), target :: global
call plot%compile_options (global)
select case (char (parse_node_get_rule_key (pn_tag)))
case ("analysis_id")
plot%id = parse_node_get_string (pn_tag)
case default
call msg_bug ("plot: name expression not implemented (yet)")
end select
end subroutine cmd_plot_init
@ %def cmd_plot_init
@ Command execution. This declares the plot and allocates it in
the analysis store.
<<Commands: cmd plot: TBP>>=
procedure :: execute => cmd_plot_execute
<<Commands: sub interfaces>>=
module subroutine cmd_plot_execute (cmd, global)
class(cmd_plot_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_plot_execute
<<Commands: procedures>>=
module subroutine cmd_plot_execute (cmd, global)
class(cmd_plot_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
type(graph_options_t) :: graph_options
type(drawing_options_t) :: drawing_options
var_list => cmd%local%get_var_list_ptr ()
call graph_options%init ()
call set_graph_options (graph_options, var_list)
call drawing_options%init_plot ()
call set_drawing_options (drawing_options, var_list)
call analysis_init_plot (cmd%id, graph_options, drawing_options)
end subroutine cmd_plot_execute
@ %def cmd_plot_execute
@
\subsubsection{Graphs}
Declare a graph. The graph is defined in terms of its contents. Both the
graph and its contents may carry options.
The graph object contains its own ID as well as the IDs of its elements. For
the elements, we reuse the [[cmd_plot_t]] defined above.
<<Commands: types>>=
type, extends (command_t) :: cmd_graph_t
private
type(string_t) :: id
integer :: n_elements = 0
type(cmd_plot_t), dimension(:), allocatable :: el
type(string_t), dimension(:), allocatable :: element_id
contains
<<Commands: cmd graph: TBP>>
end type cmd_graph_t
@ %def cmd_graph_t
@ Output. Just print the ID.
<<Commands: cmd graph: TBP>>=
procedure :: write => cmd_graph_write
<<Commands: sub interfaces>>=
module subroutine cmd_graph_write (cmd, unit, indent)
class(cmd_graph_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_graph_write
<<Commands: procedures>>=
module subroutine cmd_graph_write (cmd, unit, indent)
class(cmd_graph_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,A,A,I0,A)") "graph: ", char (cmd%id), &
" (", cmd%n_elements, " entries)"
end subroutine cmd_graph_write
@ %def cmd_graph_write
@ Compile. Record the graph ID and initialize lower, upper bound
and bin width. For compiling the graph element syntax, we use part of the
[[cmd_plot_t]] compiler.
Note: currently, we do not respect options, therefore just IDs on the RHS.
<<Commands: cmd graph: TBP>>=
procedure :: compile => cmd_graph_compile
<<Commands: sub interfaces>>=
module subroutine cmd_graph_compile (cmd, global)
class(cmd_graph_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_graph_compile
<<Commands: procedures>>=
module subroutine cmd_graph_compile (cmd, global)
class(cmd_graph_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_term, pn_tag, pn_def, pn_app
integer :: i
pn_term => parse_node_get_sub_ptr (cmd%pn, 2)
pn_tag => parse_node_get_sub_ptr (pn_term)
cmd%pn_opt => parse_node_get_next_ptr (pn_tag)
call cmd%compile_options (global)
select case (char (parse_node_get_rule_key (pn_tag)))
case ("analysis_id")
cmd%id = parse_node_get_string (pn_tag)
case default
call msg_bug ("graph: name expression not implemented (yet)")
end select
pn_def => parse_node_get_next_ptr (pn_term, 2)
cmd%n_elements = parse_node_get_n_sub (pn_def)
allocate (cmd%element_id (cmd%n_elements))
allocate (cmd%el (cmd%n_elements))
pn_term => parse_node_get_sub_ptr (pn_def)
pn_tag => parse_node_get_sub_ptr (pn_term)
cmd%el(1)%pn_opt => parse_node_get_next_ptr (pn_tag)
call cmd%el(1)%init (pn_tag, global)
cmd%element_id(1) = parse_node_get_string (pn_tag)
pn_app => parse_node_get_next_ptr (pn_term)
do i = 2, cmd%n_elements
pn_term => parse_node_get_sub_ptr (pn_app, 2)
pn_tag => parse_node_get_sub_ptr (pn_term)
cmd%el(i)%pn_opt => parse_node_get_next_ptr (pn_tag)
call cmd%el(i)%init (pn_tag, global)
cmd%element_id(i) = parse_node_get_string (pn_tag)
pn_app => parse_node_get_next_ptr (pn_app)
end do
end subroutine cmd_graph_compile
@ %def cmd_graph_compile
@ Command execution. This declares the graph, allocates it in
the analysis store, and copies the graph elements.
For the graph, we set graph and default drawing options. For the elements, we
reset individual drawing options.
This accesses internals of the contained elements of type [[cmd_plot_t]], see
above. We might disentangle such an interdependency when this code is
rewritten using proper type extension.
<<Commands: cmd graph: TBP>>=
procedure :: execute => cmd_graph_execute
<<Commands: sub interfaces>>=
module subroutine cmd_graph_execute (cmd, global)
class(cmd_graph_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_graph_execute
<<Commands: procedures>>=
module subroutine cmd_graph_execute (cmd, global)
class(cmd_graph_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
type(graph_options_t) :: graph_options
type(drawing_options_t) :: drawing_options
integer :: i, type
var_list => cmd%local%get_var_list_ptr ()
call graph_options%init ()
call set_graph_options (graph_options, var_list)
call analysis_init_graph (cmd%id, cmd%n_elements, graph_options)
do i = 1, cmd%n_elements
if (associated (cmd%el(i)%options)) then
call cmd%el(i)%options%execute (cmd%el(i)%local)
end if
type = analysis_store_get_object_type (cmd%element_id(i))
select case (type)
case (AN_HISTOGRAM)
call drawing_options%init_histogram ()
case (AN_PLOT)
call drawing_options%init_plot ()
end select
call set_drawing_options (drawing_options, var_list)
if (associated (cmd%el(i)%options)) then
call set_drawing_options (drawing_options, cmd%el(i)%local%var_list)
end if
call analysis_fill_graph (cmd%id, i, cmd%element_id(i), drawing_options)
end do
end subroutine cmd_graph_execute
@ %def cmd_graph_execute
@
\subsubsection{Analysis}
Hold the analysis ID either as a string or as an expression:
<<Commands: types>>=
type :: analysis_id_t
type(string_t) :: tag
type(parse_node_t), pointer :: pn_sexpr => null ()
end type analysis_id_t
@ %def analysis_id_t
@ Define the analysis expression. We store the parse tree for the
right-hand side instead of compiling it. Compilation is deferred to
the process environment where the analysis expression is used.
<<Commands: types>>=
type, extends (command_t) :: cmd_analysis_t
private
type(parse_node_t), pointer :: pn_lexpr => null ()
contains
<<Commands: cmd analysis: TBP>>
end type cmd_analysis_t
@ %def cmd_analysis_t
@ Output. Print just a message that analysis has been defined.
<<Commands: cmd analysis: TBP>>=
procedure :: write => cmd_analysis_write
<<Commands: sub interfaces>>=
module subroutine cmd_analysis_write (cmd, unit, indent)
class(cmd_analysis_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_analysis_write
<<Commands: procedures>>=
module subroutine cmd_analysis_write (cmd, unit, indent)
class(cmd_analysis_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)") "analysis: [defined]"
end subroutine cmd_analysis_write
@ %def cmd_analysis_write
@ Compile. Simply store the parse (sub)tree.
<<Commands: cmd analysis: TBP>>=
procedure :: compile => cmd_analysis_compile
<<Commands: sub interfaces>>=
module subroutine cmd_analysis_compile (cmd, global)
class(cmd_analysis_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_analysis_compile
<<Commands: procedures>>=
module subroutine cmd_analysis_compile (cmd, global)
class(cmd_analysis_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
cmd%pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 3)
end subroutine cmd_analysis_compile
@ %def cmd_analysis_compile
@ Instead of evaluating the cut expression, link the parse tree to the
global data set, such that it is compiled and executed in the
appropriate process context.
<<Commands: cmd analysis: TBP>>=
procedure :: execute => cmd_analysis_execute
<<Commands: sub interfaces>>=
module subroutine cmd_analysis_execute (cmd, global)
class(cmd_analysis_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_analysis_execute
<<Commands: procedures>>=
module subroutine cmd_analysis_execute (cmd, global)
class(cmd_analysis_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
global%pn%analysis_lexpr => cmd%pn_lexpr
end subroutine cmd_analysis_execute
@ %def cmd_analysis_execute
@
\subsubsection{Write histograms and plots}
The data type encapsulating the command:
<<Commands: types>>=
type, extends (command_t) :: cmd_write_analysis_t
private
type(analysis_id_t), dimension(:), allocatable :: id
type(string_t), dimension(:), allocatable :: tag
contains
<<Commands: cmd write analysis: TBP>>
end type cmd_write_analysis_t
@ %def analysis_id_t
@ %def cmd_write_analysis_t
@ Output. Just the keyword.
<<Commands: cmd write analysis: TBP>>=
procedure :: write => cmd_write_analysis_write
<<Commands: sub interfaces>>=
module subroutine cmd_write_analysis_write (cmd, unit, indent)
class(cmd_write_analysis_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_write_analysis_write
<<Commands: procedures>>=
module subroutine cmd_write_analysis_write (cmd, unit, indent)
class(cmd_write_analysis_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)") "write_analysis"
end subroutine cmd_write_analysis_write
@ %def cmd_write_analysis_write
@ Compile.
<<Commands: cmd write analysis: TBP>>=
procedure :: compile => cmd_write_analysis_compile
<<Commands: sub interfaces>>=
module subroutine cmd_write_analysis_compile (cmd, global)
class(cmd_write_analysis_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_write_analysis_compile
<<Commands: procedures>>=
module subroutine cmd_write_analysis_compile (cmd, global)
class(cmd_write_analysis_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_clause, pn_args, pn_id
integer :: n, i
pn_clause => parse_node_get_sub_ptr (cmd%pn)
pn_args => parse_node_get_sub_ptr (pn_clause, 2)
cmd%pn_opt => parse_node_get_next_ptr (pn_clause)
call cmd%compile_options (global)
if (associated (pn_args)) then
n = parse_node_get_n_sub (pn_args)
allocate (cmd%id (n))
do i = 1, n
pn_id => parse_node_get_sub_ptr (pn_args, i)
if (char (parse_node_get_rule_key (pn_id)) == "analysis_id") then
cmd%id(i)%tag = parse_node_get_string (pn_id)
else
cmd%id(i)%pn_sexpr => pn_id
end if
end do
else
allocate (cmd%id (0))
end if
end subroutine cmd_write_analysis_compile
@ %def cmd_write_analysis_compile
@ The output format for real data values:
<<Commands: parameters>>=
character(*), parameter, public :: &
DEFAULT_ANALYSIS_FILENAME = "whizard_analysis.dat"
character(len=1), dimension(2), parameter, public :: &
FORBIDDEN_ENDINGS1 = [ "o", "a" ]
character(len=2), dimension(6), parameter, public :: &
FORBIDDEN_ENDINGS2 = [ "mp", "ps", "vg", "pg", "lo", "la" ]
character(len=3), dimension(20), parameter, public :: &
FORBIDDEN_ENDINGS3 = [ "aux", "dvi", "evt", "evx", "f03", "f90", &
"f95", "log", "ltp", "mod", "mpx", "olc", "olp", "pdf", "phs", &
"sin", "sub", "tex", "vg2", "vgx" ]
@ %def DEFAULT_ANALYSIS_FILENAME
@ %def FORBIDDEN_ENDINGS1
@ %def FORBIDDEN_ENDINGS2
@ %def FORBIDDEN_ENDINGS3
@ As this contains a lot of similar code to [[cmd_compile_analysis_execute]]
we outsource the main code to a subroutine.
<<Commands: cmd write analysis: TBP>>=
procedure :: execute => cmd_write_analysis_execute
<<Commands: sub interfaces>>=
module subroutine cmd_write_analysis_execute (cmd, global)
class(cmd_write_analysis_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_write_analysis_execute
<<Commands: procedures>>=
module subroutine cmd_write_analysis_execute (cmd, global)
class(cmd_write_analysis_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
var_list => cmd%local%get_var_list_ptr ()
call write_analysis_wrap (var_list, global%out_files, &
cmd%id, tag = cmd%tag)
end subroutine cmd_write_analysis_execute
@ %def cmd_write_analysis_execute
@ If the [[data_file]] optional argument is present, this is
called from [[cmd_compile_analysis_execute]], which needs the file name for
further processing, and requires the default format. For the moment,
parameters and macros for custom data processing are disabled.
<<Commands: procedures>>=
subroutine write_analysis_wrap (var_list, out_files, id, tag, data_file)
type(var_list_t), intent(inout), target :: var_list
type(file_list_t), intent(inout), target :: out_files
type(analysis_id_t), dimension(:), intent(in), target :: id
type(string_t), dimension(:), allocatable, intent(out) :: tag
type(string_t), intent(out), optional :: data_file
type(string_t) :: defaultfile, file
integer :: i
logical :: keep_open
type(string_t) :: extension
logical :: one_file
defaultfile = var_list%get_sval (var_str ("$out_file"))
if (present (data_file)) then
if (defaultfile == "" .or. defaultfile == ".") then
defaultfile = DEFAULT_ANALYSIS_FILENAME
else
if (scan (".", defaultfile) > 0) then
call split (defaultfile, extension, ".", back=.true.)
if (any (lower_case (char(extension)) == FORBIDDEN_ENDINGS1) .or. &
any (lower_case (char(extension)) == FORBIDDEN_ENDINGS2) .or. &
any (lower_case (char(extension)) == FORBIDDEN_ENDINGS3)) &
call msg_fatal ("The ending " // char(extension) // &
" is internal and not allowed as data file.")
if (extension /= "") then
if (defaultfile /= "") then
defaultfile = defaultfile // "." // extension
else
defaultfile = "whizard_analysis." // extension
end if
else
defaultfile = defaultfile // ".dat"
endif
else
defaultfile = defaultfile // ".dat"
end if
end if
data_file = defaultfile
end if
one_file = defaultfile /= ""
if (one_file) then
file = defaultfile
keep_open = file_list_is_open (out_files, file, &
action = "write")
if (keep_open) then
if (present (data_file)) then
call msg_fatal ("Compiling analysis: File '" &
// char (data_file) &
// "' can't be used, it is already open.")
else
call msg_message ("Appending analysis data to file '" &
// char (file) // "'")
end if
else
call file_list_open (out_files, file, &
action = "write", status = "replace", position = "asis")
call msg_message ("Writing analysis data to file '" &
// char (file) // "'")
end if
end if
call get_analysis_tags (tag, id, var_list)
do i = 1, size (tag)
call file_list_write_analysis &
(out_files, file, tag(i))
end do
if (one_file .and. .not. keep_open) then
call file_list_close (out_files, file)
end if
contains
subroutine get_analysis_tags (analysis_tag, id, var_list)
type(string_t), dimension(:), intent(out), allocatable :: analysis_tag
type(analysis_id_t), dimension(:), intent(in) :: id
type(var_list_t), intent(in), target :: var_list
if (size (id) /= 0) then
allocate (analysis_tag (size (id)))
do i = 1, size (id)
if (associated (id(i)%pn_sexpr)) then
analysis_tag(i) = eval_string (id(i)%pn_sexpr, var_list)
else
analysis_tag(i) = id(i)%tag
end if
end do
else
call analysis_store_get_ids (tag)
end if
end subroutine get_analysis_tags
end subroutine write_analysis_wrap
@ %def write_analysis_wrap
\subsubsection{Compile analysis results}
This command writes files in a form suitable for GAMELAN and executes the
appropriate commands to compile them. The first part is identical to
[[cmd_write_analysis]].
<<Commands: types>>=
type, extends (command_t) :: cmd_compile_analysis_t
private
type(analysis_id_t), dimension(:), allocatable :: id
type(string_t), dimension(:), allocatable :: tag
contains
<<Commands: cmd compile analysis: TBP>>
end type cmd_compile_analysis_t
@ %def cmd_compile_analysis_t
@ Output. Just the keyword.
<<Commands: cmd compile analysis: TBP>>=
procedure :: write => cmd_compile_analysis_write
<<Commands: sub interfaces>>=
module subroutine cmd_compile_analysis_write (cmd, unit, indent)
class(cmd_compile_analysis_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_compile_analysis_write
<<Commands: procedures>>=
module subroutine cmd_compile_analysis_write (cmd, unit, indent)
class(cmd_compile_analysis_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)") "compile_analysis"
end subroutine cmd_compile_analysis_write
@ %def cmd_compile_analysis_write
@ Compile.
<<Commands: cmd compile analysis: TBP>>=
procedure :: compile => cmd_compile_analysis_compile
<<Commands: sub interfaces>>=
module subroutine cmd_compile_analysis_compile (cmd, global)
class(cmd_compile_analysis_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_compile_analysis_compile
<<Commands: procedures>>=
module subroutine cmd_compile_analysis_compile (cmd, global)
class(cmd_compile_analysis_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_clause, pn_args, pn_id
integer :: n, i
pn_clause => parse_node_get_sub_ptr (cmd%pn)
pn_args => parse_node_get_sub_ptr (pn_clause, 2)
cmd%pn_opt => parse_node_get_next_ptr (pn_clause)
call cmd%compile_options (global)
if (associated (pn_args)) then
n = parse_node_get_n_sub (pn_args)
allocate (cmd%id (n))
do i = 1, n
pn_id => parse_node_get_sub_ptr (pn_args, i)
if (char (parse_node_get_rule_key (pn_id)) == "analysis_id") then
cmd%id(i)%tag = parse_node_get_string (pn_id)
else
cmd%id(i)%pn_sexpr => pn_id
end if
end do
else
allocate (cmd%id (0))
end if
end subroutine cmd_compile_analysis_compile
@ %def cmd_compile_analysis_compile
@ First write the analysis data to file, then write a GAMELAN driver and
produce MetaPost and \TeX\ output.
<<Commands: cmd compile analysis: TBP>>=
procedure :: execute => cmd_compile_analysis_execute
<<Commands: sub interfaces>>=
module subroutine cmd_compile_analysis_execute (cmd, global)
class(cmd_compile_analysis_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_compile_analysis_execute
<<Commands: procedures>>=
module subroutine cmd_compile_analysis_execute (cmd, global)
class(cmd_compile_analysis_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
type(string_t) :: file, basename, extension, driver_file, &
makefile
integer :: u_driver, u_makefile
logical :: has_gmlcode, only_file
var_list => cmd%local%get_var_list_ptr ()
call write_analysis_wrap (var_list, &
global%out_files, cmd%id, tag = cmd%tag, &
data_file = file)
basename = file
if (scan (".", basename) > 0) then
call split (basename, extension, ".", back=.true.)
else
extension = ""
end if
driver_file = basename // ".tex"
makefile = basename // "_ana.makefile"
u_driver = free_unit ()
open (unit=u_driver, file=char(driver_file), &
action="write", status="replace")
if (allocated (cmd%tag)) then
call analysis_write_driver (file, cmd%tag, unit=u_driver)
has_gmlcode = analysis_has_plots (cmd%tag)
else
call analysis_write_driver (file, unit=u_driver)
has_gmlcode = analysis_has_plots ()
end if
close (u_driver)
u_makefile = free_unit ()
open (unit=u_makefile, file=char(makefile), &
action="write", status="replace")
call analysis_write_makefile (basename, u_makefile, &
has_gmlcode, global%os_data)
close (u_makefile)
call msg_message ("Compiling analysis results display in '" &
// char (driver_file) // "'")
call msg_message ("Providing analysis steering makefile '" &
// char (makefile) // "'")
only_file = global%var_list%get_lval &
(var_str ("?analysis_file_only"))
if (.not. only_file) call analysis_compile_tex &
(basename, has_gmlcode, global%os_data)
end subroutine cmd_compile_analysis_execute
@ %def cmd_compile_analysis_execute
@
\subsection{User-controlled output to data files}
\subsubsection{Open file (output)}
Open a file for output.
<<Commands: types>>=
type, extends (command_t) :: cmd_open_out_t
private
type(parse_node_t), pointer :: file_expr => null ()
contains
<<Commands: cmd open out: TBP>>
end type cmd_open_out_t
@ %def cmd_open_out
@ Finalizer for the embedded eval tree.
<<Commands: procedures>>=
subroutine cmd_open_out_final (object)
class(cmd_open_out_t), intent(inout) :: object
end subroutine cmd_open_out_final
@ %def cmd_open_out_final
@ Output (trivial here).
<<Commands: cmd open out: TBP>>=
procedure :: write => cmd_open_out_write
<<Commands: sub interfaces>>=
module subroutine cmd_open_out_write (cmd, unit, indent)
class(cmd_open_out_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_open_out_write
<<Commands: procedures>>=
module subroutine cmd_open_out_write (cmd, unit, indent)
class(cmd_open_out_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)", advance="no") "open_out: <filename>"
end subroutine cmd_open_out_write
@ %def cmd_open_out_write
@ Compile: create an eval tree for the filename expression.
<<Commands: cmd open out: TBP>>=
procedure :: compile => cmd_open_out_compile
<<Commands: sub interfaces>>=
module subroutine cmd_open_out_compile (cmd, global)
class(cmd_open_out_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_open_out_compile
<<Commands: procedures>>=
module subroutine cmd_open_out_compile (cmd, global)
class(cmd_open_out_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
cmd%file_expr => parse_node_get_sub_ptr (cmd%pn, 2)
if (associated (cmd%file_expr)) then
cmd%pn_opt => parse_node_get_next_ptr (cmd%file_expr)
end if
call cmd%compile_options (global)
end subroutine cmd_open_out_compile
@ %def cmd_open_out_compile
@ Execute: append the file to the global list of open files.
<<Commands: cmd open out: TBP>>=
procedure :: execute => cmd_open_out_execute
<<Commands: sub interfaces>>=
module subroutine cmd_open_out_execute (cmd, global)
class(cmd_open_out_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_open_out_execute
<<Commands: procedures>>=
module subroutine cmd_open_out_execute (cmd, global)
class(cmd_open_out_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
type(eval_tree_t) :: file_expr
type(string_t) :: file
var_list => cmd%local%get_var_list_ptr ()
call file_expr%init_sexpr (cmd%file_expr, var_list)
call file_expr%evaluate ()
if (file_expr%is_known ()) then
file = file_expr%get_string ()
call file_list_open (global%out_files, file, &
action = "write", status = "replace", position = "asis")
else
call msg_fatal ("open_out: file name argument evaluates to unknown")
end if
call file_expr%final ()
end subroutine cmd_open_out_execute
@ %def cmd_open_out_execute
\subsubsection{Open file (output)}
Close an output file. Except for the [[execute]] method, everything is
analogous to the open command, so we can just inherit.
<<Commands: types>>=
type, extends (cmd_open_out_t) :: cmd_close_out_t
private
contains
<<Commands: cmd close out: TBP>>
end type cmd_close_out_t
@ %def cmd_close_out
@ Execute: remove the file from the global list of output files.
<<Commands: cmd close out: TBP>>=
procedure :: execute => cmd_close_out_execute
<<Commands: sub interfaces>>=
module subroutine cmd_close_out_execute (cmd, global)
class(cmd_close_out_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_close_out_execute
<<Commands: procedures>>=
module subroutine cmd_close_out_execute (cmd, global)
class(cmd_close_out_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
type(eval_tree_t) :: file_expr
type(string_t) :: file
var_list => cmd%local%var_list
call file_expr%init_sexpr (cmd%file_expr, var_list)
call file_expr%evaluate ()
if (file_expr%is_known ()) then
file = file_expr%get_string ()
call file_list_close (global%out_files, file)
else
call msg_fatal ("close_out: file name argument evaluates to unknown")
end if
call file_expr%final ()
end subroutine cmd_close_out_execute
@ %def cmd_close_out_execute
@
\subsection{Print custom-formatted values}
<<Commands: types>>=
type, extends (command_t) :: cmd_printf_t
private
type(parse_node_t), pointer :: sexpr => null ()
type(parse_node_t), pointer :: sprintf_fun => null ()
type(parse_node_t), pointer :: sprintf_clause => null ()
type(parse_node_t), pointer :: sprintf => null ()
contains
<<Commands: cmd printf: TBP>>
end type cmd_printf_t
@ %def cmd_printf_t
@ Finalize.
<<Commands: cmd printf: TBP>>=
procedure :: final => cmd_printf_final
<<Commands: sub interfaces>>=
module subroutine cmd_printf_final (cmd)
class(cmd_printf_t), intent(inout) :: cmd
end subroutine cmd_printf_final
<<Commands: procedures>>=
module subroutine cmd_printf_final (cmd)
class(cmd_printf_t), intent(inout) :: cmd
call parse_node_final (cmd%sexpr, recursive = .false.)
deallocate (cmd%sexpr)
call parse_node_final (cmd%sprintf_fun, recursive = .false.)
deallocate (cmd%sprintf_fun)
call parse_node_final (cmd%sprintf_clause, recursive = .false.)
deallocate (cmd%sprintf_clause)
call parse_node_final (cmd%sprintf, recursive = .false.)
deallocate (cmd%sprintf)
end subroutine cmd_printf_final
@ %def cmd_printf_final
@ Output. Do not print the parse tree, since this may get cluttered.
Just a message that cuts have been defined.
<<Commands: cmd printf: TBP>>=
procedure :: write => cmd_printf_write
<<Commands: sub interfaces>>=
module subroutine cmd_printf_write (cmd, unit, indent)
class(cmd_printf_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_printf_write
<<Commands: procedures>>=
module subroutine cmd_printf_write (cmd, unit, indent)
class(cmd_printf_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)") "printf:"
end subroutine cmd_printf_write
@ %def cmd_printf_write
@ Compile. We create a fake parse node (subtree) with a [[sprintf]] command
with identical arguments which can then be handled by the corresponding
evaluation procedure.
<<Commands: cmd printf: TBP>>=
procedure :: compile => cmd_printf_compile
<<Commands: sub interfaces>>=
module subroutine cmd_printf_compile (cmd, global)
class(cmd_printf_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_printf_compile
<<Commands: procedures>>=
module subroutine cmd_printf_compile (cmd, global)
class(cmd_printf_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_cmd, pn_clause, pn_args, pn_format
pn_cmd => parse_node_get_sub_ptr (cmd%pn)
pn_clause => parse_node_get_sub_ptr (pn_cmd)
pn_format => parse_node_get_sub_ptr (pn_clause, 2)
pn_args => parse_node_get_next_ptr (pn_clause)
cmd%pn_opt => parse_node_get_next_ptr (pn_cmd)
call cmd%compile_options (global)
allocate (cmd%sexpr)
call parse_node_create_branch (cmd%sexpr, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("sexpr")))
allocate (cmd%sprintf_fun)
call parse_node_create_branch (cmd%sprintf_fun, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf_fun")))
allocate (cmd%sprintf_clause)
call parse_node_create_branch (cmd%sprintf_clause, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf_clause")))
allocate (cmd%sprintf)
call parse_node_create_key (cmd%sprintf, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf")))
call parse_node_append_sub (cmd%sprintf_clause, cmd%sprintf)
call parse_node_append_sub (cmd%sprintf_clause, pn_format)
call parse_node_freeze_branch (cmd%sprintf_clause)
call parse_node_append_sub (cmd%sprintf_fun, cmd%sprintf_clause)
if (associated (pn_args)) then
call parse_node_append_sub (cmd%sprintf_fun, pn_args)
end if
call parse_node_freeze_branch (cmd%sprintf_fun)
call parse_node_append_sub (cmd%sexpr, cmd%sprintf_fun)
call parse_node_freeze_branch (cmd%sexpr)
end subroutine cmd_printf_compile
@ %def cmd_printf_compile
@ Execute. Evaluate the string (pretending this is a [[sprintf]] expression)
and print it.
<<Commands: cmd printf: TBP>>=
procedure :: execute => cmd_printf_execute
<<Commands: sub interfaces>>=
module subroutine cmd_printf_execute (cmd, global)
class(cmd_printf_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_printf_execute
<<Commands: procedures>>=
module subroutine cmd_printf_execute (cmd, global)
class(cmd_printf_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
type(string_t) :: string, file
type(eval_tree_t) :: sprintf_expr
logical :: advance
var_list => cmd%local%get_var_list_ptr ()
advance = var_list%get_lval (&
var_str ("?out_advance"))
file = var_list%get_sval (&
var_str ("$out_file"))
call sprintf_expr%init_sexpr (cmd%sexpr, var_list)
call sprintf_expr%evaluate ()
if (sprintf_expr%is_known ()) then
string = sprintf_expr%get_string ()
if (len (file) == 0) then
call msg_result (char (string))
else
call file_list_write (global%out_files, file, string, advance)
end if
end if
end subroutine cmd_printf_execute
@ %def cmd_printf_execute
@
\subsubsection{Record data}
The expression syntax already contains a [[record]] keyword; this evaluates to
a logical which is always true, but it has the side-effect of recording data
into analysis objects. Here we define a command as an interface to this
construct.
<<Commands: types>>=
type, extends (command_t) :: cmd_record_t
private
type(parse_node_t), pointer :: pn_lexpr => null ()
contains
<<Commands: cmd record: TBP>>
end type cmd_record_t
@ %def cmd_record_t
@ Output. With the compile hack below, there is nothing of interest
to print here.
<<Commands: cmd record: TBP>>=
procedure :: write => cmd_record_write
<<Commands: sub interfaces>>=
module subroutine cmd_record_write (cmd, unit, indent)
class(cmd_record_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_record_write
<<Commands: procedures>>=
module subroutine cmd_record_write (cmd, unit, indent)
class(cmd_record_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)") "record"
end subroutine cmd_record_write
@ %def cmd_record_write
@ Compile. This is a hack which transforms the [[record]] command
into a [[record]] expression, which we handle in the [[expressions]]
module.
<<Commands: cmd record: TBP>>=
procedure :: compile => cmd_record_compile
<<Commands: sub interfaces>>=
module subroutine cmd_record_compile (cmd, global)
class(cmd_record_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_record_compile
<<Commands: procedures>>=
module subroutine cmd_record_compile (cmd, global)
class(cmd_record_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_lexpr, pn_lsinglet, pn_lterm, pn_record
call parse_node_create_branch (pn_lexpr, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("lexpr")))
call parse_node_create_branch (pn_lsinglet, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("lsinglet")))
call parse_node_append_sub (pn_lexpr, pn_lsinglet)
call parse_node_create_branch (pn_lterm, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("lterm")))
call parse_node_append_sub (pn_lsinglet, pn_lterm)
pn_record => parse_node_get_sub_ptr (cmd%pn)
call parse_node_append_sub (pn_lterm, pn_record)
cmd%pn_lexpr => pn_lexpr
end subroutine cmd_record_compile
@ %def cmd_record_compile
@ Command execution. Again, transfer this to the embedded expression
and just forget the logical result.
<<Commands: cmd record: TBP>>=
procedure :: execute => cmd_record_execute
<<Commands: sub interfaces>>=
module subroutine cmd_record_execute (cmd, global)
class(cmd_record_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_record_execute
<<Commands: procedures>>=
module subroutine cmd_record_execute (cmd, global)
class(cmd_record_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
logical :: lval
var_list => global%get_var_list_ptr ()
lval = eval_log (cmd%pn_lexpr, var_list)
end subroutine cmd_record_execute
@ %def cmd_record_execute
@
\subsubsection{Unstable particles}
Mark a particle as unstable. For each unstable particle, we store a
number of decay channels and compute their respective BRs.
<<Commands: types>>=
type, extends (command_t) :: cmd_unstable_t
private
integer :: n_proc = 0
type(string_t), dimension(:), allocatable :: process_id
type(parse_node_t), pointer :: pn_prt_in => null ()
contains
<<Commands: cmd unstable: TBP>>
end type cmd_unstable_t
@ %def cmd_unstable_t
@ Output: we know the process IDs.
<<Commands: cmd unstable: TBP>>=
procedure :: write => cmd_unstable_write
<<Commands: sub interfaces>>=
module subroutine cmd_unstable_write (cmd, unit, indent)
class(cmd_unstable_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_unstable_write
<<Commands: procedures>>=
module subroutine cmd_unstable_write (cmd, unit, indent)
class(cmd_unstable_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,1x,I0,1x,A)", advance="no") &
"unstable:", 1, "("
do i = 1, cmd%n_proc
if (i > 1) write (u, "(A,1x)", advance="no") ","
write (u, "(A)", advance="no") char (cmd%process_id(i))
end do
write (u, "(A)") ")"
end subroutine cmd_unstable_write
@ %def cmd_unstable_write
@ Compile. Initiate an eval tree for the decaying particle and
determine the decay channel process IDs.
<<Commands: cmd unstable: TBP>>=
procedure :: compile => cmd_unstable_compile
<<Commands: sub interfaces>>=
module subroutine cmd_unstable_compile (cmd, global)
class(cmd_unstable_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_unstable_compile
<<Commands: procedures>>=
module subroutine cmd_unstable_compile (cmd, global)
class(cmd_unstable_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_list, pn_proc
integer :: i
cmd%pn_prt_in => parse_node_get_sub_ptr (cmd%pn, 2)
pn_list => parse_node_get_next_ptr (cmd%pn_prt_in)
if (associated (pn_list)) then
select case (char (parse_node_get_rule_key (pn_list)))
case ("unstable_arg")
cmd%n_proc = parse_node_get_n_sub (pn_list)
cmd%pn_opt => parse_node_get_next_ptr (pn_list)
case default
cmd%n_proc = 0
cmd%pn_opt => pn_list
pn_list => null ()
end select
end if
call cmd%compile_options (global)
if (associated (pn_list)) then
allocate (cmd%process_id (cmd%n_proc))
pn_proc => parse_node_get_sub_ptr (pn_list)
do i = 1, cmd%n_proc
cmd%process_id(i) = parse_node_get_string (pn_proc)
call cmd%local%process_stack%init_result_vars (cmd%process_id(i))
pn_proc => parse_node_get_next_ptr (pn_proc)
end do
else
allocate (cmd%process_id (0))
end if
end subroutine cmd_unstable_compile
@ %def cmd_unstable_compile
@ Command execution. Evaluate the decaying particle and mark the decays in
the current model object.
<<Commands: cmd unstable: TBP>>=
procedure :: execute => cmd_unstable_execute
<<Commands: sub interfaces>>=
module subroutine cmd_unstable_execute (cmd, global)
class(cmd_unstable_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_unstable_execute
<<Commands: procedures>>=
module subroutine cmd_unstable_execute (cmd, global)
class(cmd_unstable_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
logical :: auto_decays, auto_decays_radiative
integer :: auto_decays_multiplicity
logical :: isotropic_decay, diagonal_decay, polarized_decay
integer :: decay_helicity
type(pdg_array_t) :: pa_in
integer :: pdg_in
type(string_t) :: libname_cur, libname_dec
type(string_t), dimension(:), allocatable :: auto_id, tmp_id
integer :: n_proc_user
integer :: i, u_tmp
character(80) :: buffer
var_list => cmd%local%get_var_list_ptr ()
auto_decays = &
var_list%get_lval (var_str ("?auto_decays"))
if (auto_decays) then
auto_decays_multiplicity = &
var_list%get_ival (var_str ("auto_decays_multiplicity"))
auto_decays_radiative = &
var_list%get_lval (var_str ("?auto_decays_radiative"))
end if
isotropic_decay = &
var_list%get_lval (var_str ("?isotropic_decay"))
if (isotropic_decay) then
diagonal_decay = .false.
polarized_decay = .false.
else
diagonal_decay = &
var_list%get_lval (var_str ("?diagonal_decay"))
if (diagonal_decay) then
polarized_decay = .false.
else
polarized_decay = &
var_list%is_known (var_str ("decay_helicity"))
if (polarized_decay) then
decay_helicity = var_list%get_ival (var_str ("decay_helicity"))
end if
end if
end if
pa_in = eval_pdg_array (cmd%pn_prt_in, var_list)
if (pa_in%get_length () /= 1) &
call msg_fatal ("Unstable: decaying particle must be unique")
pdg_in = pa_in%get (1)
n_proc_user = cmd%n_proc
if (auto_decays) then
call create_auto_decays (pdg_in, &
auto_decays_multiplicity, auto_decays_radiative, &
libname_dec, auto_id, cmd%local)
allocate (tmp_id (cmd%n_proc + size (auto_id)))
tmp_id(:cmd%n_proc) = cmd%process_id
tmp_id(cmd%n_proc+1:) = auto_id
call move_alloc (from = tmp_id, to = cmd%process_id)
cmd%n_proc = size (cmd%process_id)
end if
libname_cur = cmd%local%prclib%get_name ()
do i = 1, cmd%n_proc
if (i == n_proc_user + 1) then
call cmd%local%update_prclib &
(cmd%local%prclib_stack%get_library_ptr (libname_dec))
end if
if (.not. global%process_stack%exists (cmd%process_id(i))) then
call var_list%set_log &
(var_str ("?decay_rest_frame"), .false., is_known = .true.)
call integrate_process (cmd%process_id(i), cmd%local, global)
call global%process_stack%fill_result_vars (cmd%process_id(i))
end if
end do
call cmd%local%update_prclib &
(cmd%local%prclib_stack%get_library_ptr (libname_cur))
if (cmd%n_proc > 0) then
if (polarized_decay) then
call global%modify_particle (pdg_in, stable = .false., &
decay = cmd%process_id, &
isotropic_decay = .false., &
diagonal_decay = .false., &
decay_helicity = decay_helicity, &
polarized = .false.)
else
call global%modify_particle (pdg_in, stable = .false., &
decay = cmd%process_id, &
isotropic_decay = isotropic_decay, &
diagonal_decay = diagonal_decay, &
polarized = .false.)
end if
u_tmp = free_unit ()
open (u_tmp, status = "scratch", action = "readwrite")
call show_unstable (global, pdg_in, u_tmp)
rewind (u_tmp)
do
read (u_tmp, "(A)", end = 1) buffer
write (msg_buffer, "(A)") trim (buffer)
call msg_message ()
end do
1 continue
close (u_tmp)
else
call err_unstable (global, pdg_in)
end if
end subroutine cmd_unstable_execute
@ %def cmd_unstable_execute
@ Show data for the current unstable particle. This is called both by
the [[unstable]] and by the [[show]] command.
To determine decay branching rations, we look at the decay process IDs
and inspect the corresponding [[integral()]] result variables.
<<Commands: procedures>>=
subroutine show_unstable (global, pdg, u)
type(rt_data_t), intent(in), target :: global
integer, intent(in) :: pdg, u
type(flavor_t) :: flv
type(string_t), dimension(:), allocatable :: decay
real(default), dimension(:), allocatable :: br
real(default) :: width
type(process_t), pointer :: process
type(process_component_def_t), pointer :: prc_def
type(string_t), dimension(:), allocatable :: prt_out, prt_out_str
integer :: i, j
logical :: opened
call flv%init (pdg, global%model)
call flv%get_decays (decay)
if (.not. allocated (decay)) return
allocate (prt_out_str (size (decay)))
allocate (br (size (decay)))
do i = 1, size (br)
process => global%process_stack%get_process_ptr (decay(i))
prc_def => process%get_component_def_ptr (1)
call prc_def%get_prt_out (prt_out)
prt_out_str(i) = prt_out(1)
do j = 2, size (prt_out)
prt_out_str(i) = prt_out_str(i) // ", " // prt_out(j)
end do
br(i) = global%get_rval ("integral(" // decay(i) // ")")
end do
if (all (br >= 0)) then
if (any (br > 0)) then
width = sum (br)
br = br / sum (br)
write (u, "(A)") "Unstable particle " &
// char (flv%get_name ()) &
// ": computed branching ratios:"
do i = 1, size (br)
write (u, "(2x,A,':'," // FMT_14 // ",3x,A)") &
char (decay(i)), br(i), char (prt_out_str(i))
end do
write (u, "(2x,'Total width ='," // FMT_14 // ",' GeV (computed)')") width
write (u, "(2x,' ='," // FMT_14 // ",' GeV (preset)')") &
flv%get_width ()
if (flv%decays_isotropically ()) then
write (u, "(2x,A)") "Decay options: isotropic"
else if (flv%decays_diagonal ()) then
write (u, "(2x,A)") "Decay options: &
&projection on diagonal helicity states"
else if (flv%has_decay_helicity ()) then
write (u, "(2x,A,1x,I0)") "Decay options: projection onto helicity =", &
flv%get_decay_helicity ()
else
write (u, "(2x,A)") "Decay options: helicity treated exactly"
end if
else
inquire (unit = u, opened = opened)
if (opened .and. .not. mask_fatal_errors) close (u)
call msg_fatal ("Unstable particle " &
// char (flv%get_name ()) &
// ": partial width vanishes for all decay channels")
end if
else
inquire (unit = u, opened = opened)
if (opened .and. .not. mask_fatal_errors) close (u)
call msg_fatal ("Unstable particle " &
// char (flv%get_name ()) &
// ": partial width is negative")
end if
end subroutine show_unstable
@ %def show_unstable
@ If no decays have been found, issue a non-fatal error.
<<Commands: procedures>>=
subroutine err_unstable (global, pdg)
type(rt_data_t), intent(in), target :: global
integer, intent(in) :: pdg
type(flavor_t) :: flv
call flv%init (pdg, global%model)
call msg_error ("Unstable: no allowed decays found for particle " &
// char (flv%get_name ()) // ", keeping as stable")
end subroutine err_unstable
@ %def err_unstable
@ Auto decays: create process IDs and make up process
configurations, using the PDG codes generated by the [[ds_table]] make
method.
We allocate and use a self-contained process library that contains only the
decay processes of the current particle. When done, we revert the global
library pointer to the original library but return the name of the new one.
The new library becomes part of the global library stack and can thus be
referred to at any time.
<<Commands: procedures>>=
subroutine create_auto_decays &
(pdg_in, mult, rad, libname_dec, process_id, global)
integer, intent(in) :: pdg_in
integer, intent(in) :: mult
logical, intent(in) :: rad
type(string_t), intent(out) :: libname_dec
type(string_t), dimension(:), allocatable, intent(out) :: process_id
type(rt_data_t), intent(inout) :: global
type(prclib_entry_t), pointer :: lib_entry
type(process_library_t), pointer :: lib
type(ds_table_t) :: ds_table
type(split_constraints_t) :: constraints
type(pdg_array_t), dimension(:), allocatable :: pa_out
character(80) :: buffer
character :: p_or_a
type(string_t) :: process_string, libname_cur
type(flavor_t) :: flv_in, flv_out
type(string_t) :: prt_in
type(string_t), dimension(:), allocatable :: prt_out
type(process_configuration_t) :: prc_config
integer :: i, j, k
call flv_in%init (pdg_in, global%model)
if (rad) then
call constraints%init (2)
else
call constraints%init (3)
call constraints%set (3, constrain_radiation ())
end if
call constraints%set (1, constrain_n_tot (mult))
call constraints%set (2, &
constrain_mass_sum (flv_in%get_mass (), margin = 0._default))
call ds_table%make (global%model, pdg_in, constraints)
prt_in = flv_in%get_name ()
if (pdg_in > 0) then
p_or_a = "p"
else
p_or_a = "a"
end if
if (ds_table%get_length () == 0) then
call msg_warning ("Auto-decays: Particle " // char (prt_in) // ": " &
// "no decays found")
libname_dec = ""
allocate (process_id (0))
else
call msg_message ("Creating decay process library for particle " &
// char (prt_in))
libname_cur = global%prclib%get_name ()
write (buffer, "(A,A,I0)") "_d", p_or_a, abs (pdg_in)
libname_dec = libname_cur // trim (buffer)
lib => global%prclib_stack%get_library_ptr (libname_dec)
if (.not. (associated (lib))) then
allocate (lib_entry)
call lib_entry%init (libname_dec)
lib => lib_entry%process_library_t
call global%add_prclib (lib_entry)
else
call global%update_prclib (lib)
end if
allocate (process_id (ds_table%get_length ()))
do i = 1, size (process_id)
write (buffer, "(A,'_',A,I0,'_',I0)") &
"decay", p_or_a, abs (pdg_in), i
process_id(i) = trim (buffer)
process_string = process_id(i) // ": " // prt_in // " =>"
call ds_table%get_pdg_out (i, pa_out)
allocate (prt_out (size (pa_out)))
do j = 1, size (pa_out)
do k = 1, pa_out(j)%get_length ()
call flv_out%init (pa_out(j)%get (k), global%model)
if (k == 1) then
prt_out(j) = flv_out%get_name ()
else
prt_out(j) = prt_out(j) // ":" // flv_out%get_name ()
end if
end do
process_string = process_string // " " // prt_out(j)
end do
call msg_message (char (process_string))
call prc_config%init (process_id(i), 1, 1, &
global%model, global%var_list, &
nlo_process = global%nlo_fixed_order)
call prc_config%setup_component (1, new_prt_spec ([prt_in]), &
new_prt_spec (prt_out), global%model, global%var_list)
call prc_config%record (global)
deallocate (prt_out)
deallocate (pa_out)
end do
lib => global%prclib_stack%get_library_ptr (libname_cur)
call global%update_prclib (lib)
end if
call ds_table%final ()
end subroutine create_auto_decays
@ %def create_auto_decays
@
\subsubsection{(Stable particles}
Revert the unstable declaration for a list of particles.
<<Commands: types>>=
type, extends (command_t) :: cmd_stable_t
private
type(parse_node_p), dimension(:), allocatable :: pn_pdg
contains
<<Commands: cmd stable: TBP>>
end type cmd_stable_t
@ %def cmd_stable_t
@ Output: we know only the number of particles.
<<Commands: cmd stable: TBP>>=
procedure :: write => cmd_stable_write
<<Commands: sub interfaces>>=
module subroutine cmd_stable_write (cmd, unit, indent)
class(cmd_stable_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_stable_write
<<Commands: procedures>>=
module subroutine cmd_stable_write (cmd, unit, indent)
class(cmd_stable_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,1x,I0)") "stable:", size (cmd%pn_pdg)
end subroutine cmd_stable_write
@ %def cmd_stable_write
@ Compile. Assign parse nodes for the particle IDs.
<<Commands: cmd stable: TBP>>=
procedure :: compile => cmd_stable_compile
<<Commands: sub interfaces>>=
module subroutine cmd_stable_compile (cmd, global)
class(cmd_stable_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_stable_compile
<<Commands: procedures>>=
module subroutine cmd_stable_compile (cmd, global)
class(cmd_stable_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_list, pn_prt
integer :: n, i
pn_list => parse_node_get_sub_ptr (cmd%pn, 2)
cmd%pn_opt => parse_node_get_next_ptr (pn_list)
call cmd%compile_options (global)
n = parse_node_get_n_sub (pn_list)
allocate (cmd%pn_pdg (n))
pn_prt => parse_node_get_sub_ptr (pn_list)
i = 1
do while (associated (pn_prt))
cmd%pn_pdg(i)%ptr => pn_prt
pn_prt => parse_node_get_next_ptr (pn_prt)
i = i + 1
end do
end subroutine cmd_stable_compile
@ %def cmd_stable_compile
@ Execute: apply the modifications to the current model.
<<Commands: cmd stable: TBP>>=
procedure :: execute => cmd_stable_execute
<<Commands: sub interfaces>>=
module subroutine cmd_stable_execute (cmd, global)
class(cmd_stable_t), intent(inout) :: cmd
type(rt_data_t), target, intent(inout) :: global
end subroutine cmd_stable_execute
<<Commands: procedures>>=
module subroutine cmd_stable_execute (cmd, global)
class(cmd_stable_t), intent(inout) :: cmd
type(rt_data_t), target, intent(inout) :: global
type(var_list_t), pointer :: var_list
type(pdg_array_t) :: pa
integer :: pdg
type(flavor_t) :: flv
integer :: i
var_list => cmd%local%get_var_list_ptr ()
do i = 1, size (cmd%pn_pdg)
pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list)
if (pa%get_length () /= 1) &
call msg_fatal ("Stable: listed particles must be unique")
pdg = pa%get (1)
call global%modify_particle (pdg, stable = .true., &
isotropic_decay = .false., &
diagonal_decay = .false., &
polarized = .false.)
call flv%init (pdg, cmd%local%model)
call msg_message ("Particle " &
// char (flv%get_name ()) &
// " declared as stable")
end do
end subroutine cmd_stable_execute
@ %def cmd_stable_execute
@
\subsubsection{Polarized particles}
These commands mark particles as (un)polarized, to be applied in
subsequent simulation passes. Since this is technically the same as
the [[stable]] command, we take a shortcut and make this an extension,
just overriding methods.
<<Commands: types>>=
type, extends (cmd_stable_t) :: cmd_polarized_t
contains
<<Commands: cmd polarized: TBP>>
end type cmd_polarized_t
type, extends (cmd_stable_t) :: cmd_unpolarized_t
contains
<<Commands: cmd unpolarized: TBP>>
end type cmd_unpolarized_t
@ %def cmd_polarized_t cmd_unpolarized_t
@ Output: we know only the number of particles.
<<Commands: cmd polarized: TBP>>=
procedure :: write => cmd_polarized_write
<<Commands: cmd unpolarized: TBP>>=
procedure :: write => cmd_unpolarized_write
<<Commands: sub interfaces>>=
module subroutine cmd_polarized_write (cmd, unit, indent)
class(cmd_polarized_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_polarized_write
module subroutine cmd_unpolarized_write (cmd, unit, indent)
class(cmd_unpolarized_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_unpolarized_write
<<Commands: procedures>>=
module subroutine cmd_polarized_write (cmd, unit, indent)
class(cmd_polarized_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,1x,I0)") "polarized:", size (cmd%pn_pdg)
end subroutine cmd_polarized_write
module subroutine cmd_unpolarized_write (cmd, unit, indent)
class(cmd_unpolarized_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,1x,I0)") "unpolarized:", size (cmd%pn_pdg)
end subroutine cmd_unpolarized_write
@ %def cmd_polarized_write
@ %def cmd_unpolarized_write
@ Compile: accounted for by the base command.
Execute: apply the modifications to the current model.
<<Commands: cmd polarized: TBP>>=
procedure :: execute => cmd_polarized_execute
<<Commands: cmd unpolarized: TBP>>=
procedure :: execute => cmd_unpolarized_execute
<<Commands: sub interfaces>>=
module subroutine cmd_polarized_execute (cmd, global)
class(cmd_polarized_t), intent(inout) :: cmd
type(rt_data_t), target, intent(inout) :: global
end subroutine cmd_polarized_execute
module subroutine cmd_unpolarized_execute (cmd, global)
class(cmd_unpolarized_t), intent(inout) :: cmd
type(rt_data_t), target, intent(inout) :: global
end subroutine cmd_unpolarized_execute
<<Commands: procedures>>=
module subroutine cmd_polarized_execute (cmd, global)
class(cmd_polarized_t), intent(inout) :: cmd
type(rt_data_t), target, intent(inout) :: global
type(var_list_t), pointer :: var_list
type(pdg_array_t) :: pa
integer :: pdg
type(flavor_t) :: flv
integer :: i
var_list => cmd%local%get_var_list_ptr ()
do i = 1, size (cmd%pn_pdg)
pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list)
if (pa%get_length () /= 1) &
call msg_fatal ("Polarized: listed particles must be unique")
pdg = pa%get (1)
call global%modify_particle (pdg, polarized = .true., &
stable = .true., &
isotropic_decay = .false., &
diagonal_decay = .false.)
call flv%init (pdg, cmd%local%model)
call msg_message ("Particle " &
// char (flv%get_name ()) &
// " declared as polarized")
end do
end subroutine cmd_polarized_execute
module subroutine cmd_unpolarized_execute (cmd, global)
class(cmd_unpolarized_t), intent(inout) :: cmd
type(rt_data_t), target, intent(inout) :: global
type(var_list_t), pointer :: var_list
type(pdg_array_t) :: pa
integer :: pdg
type(flavor_t) :: flv
integer :: i
var_list => cmd%local%get_var_list_ptr ()
do i = 1, size (cmd%pn_pdg)
pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list)
if (pa%get_length () /= 1) &
call msg_fatal ("Unpolarized: listed particles must be unique")
pdg = pa%get (1)
call global%modify_particle (pdg, polarized = .false., &
stable = .true., &
isotropic_decay = .false., &
diagonal_decay = .false.)
call flv%init (pdg, cmd%local%model)
call msg_message ("Particle " &
// char (flv%get_name ()) &
// " declared as unpolarized")
end do
end subroutine cmd_unpolarized_execute
@ %def cmd_polarized_execute
@ %def cmd_unpolarized_execute
@
\subsubsection{Parameters: formats for event-sample output}
Specify all event formats that are to be used for output files in the
subsequent simulation run. (The raw format is on by default and can be turned
off here.)
<<Commands: types>>=
type, extends (command_t) :: cmd_sample_format_t
private
type(string_t), dimension(:), allocatable :: format
contains
<<Commands: cmd sample format: TBP>>
end type cmd_sample_format_t
@ %def cmd_sample_format_t
@ Output: here, everything is known.
<<Commands: cmd sample format: TBP>>=
procedure :: write => cmd_sample_format_write
<<Commands: sub interfaces>>=
module subroutine cmd_sample_format_write (cmd, unit, indent)
class(cmd_sample_format_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_sample_format_write
<<Commands: procedures>>=
module subroutine cmd_sample_format_write (cmd, unit, indent)
class(cmd_sample_format_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)", advance="no") "sample_format = "
do i = 1, size (cmd%format)
if (i > 1) write (u, "(A,1x)", advance="no") ","
write (u, "(A)", advance="no") char (cmd%format(i))
end do
write (u, "(A)")
end subroutine cmd_sample_format_write
@ %def cmd_sample_format_write
@ Compile. Initialize evaluation trees.
<<Commands: cmd sample format: TBP>>=
procedure :: compile => cmd_sample_format_compile
<<Commands: sub interfaces>>=
module subroutine cmd_sample_format_compile (cmd, global)
class(cmd_sample_format_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_sample_format_compile
<<Commands: procedures>>=
module subroutine cmd_sample_format_compile (cmd, global)
class(cmd_sample_format_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_arg
type(parse_node_t), pointer :: pn_format
integer :: i, n_format
pn_arg => parse_node_get_sub_ptr (cmd%pn, 3)
if (associated (pn_arg)) then
n_format = parse_node_get_n_sub (pn_arg)
allocate (cmd%format (n_format))
pn_format => parse_node_get_sub_ptr (pn_arg)
i = 0
do while (associated (pn_format))
i = i + 1
cmd%format(i) = parse_node_get_string (pn_format)
pn_format => parse_node_get_next_ptr (pn_format)
end do
else
allocate (cmd%format (0))
end if
end subroutine cmd_sample_format_compile
@ %def cmd_sample_format_compile
@ Execute. Transfer the list of format specifications to the
corresponding array in the runtime data set.
<<Commands: cmd sample format: TBP>>=
procedure :: execute => cmd_sample_format_execute
<<Commands: sub interfaces>>=
module subroutine cmd_sample_format_execute (cmd, global)
class(cmd_sample_format_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_sample_format_execute
<<Commands: procedures>>=
module subroutine cmd_sample_format_execute (cmd, global)
class(cmd_sample_format_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
if (allocated (global%sample_fmt)) deallocate (global%sample_fmt)
allocate (global%sample_fmt (size (cmd%format)), source = cmd%format)
end subroutine cmd_sample_format_execute
@ %def cmd_sample_format_execute
@
\subsubsection{The simulate command}
This is the actual SINDARIN command.
<<Commands: types>>=
type, extends (command_t) :: cmd_simulate_t
! not private anymore as required by the whizard-c-interface
integer :: n_proc = 0
type(string_t), dimension(:), allocatable :: process_id
contains
<<Commands: cmd simulate: TBP>>
end type cmd_simulate_t
@ %def cmd_simulate_t
@ Output: we know the process IDs.
<<Commands: cmd simulate: TBP>>=
procedure :: write => cmd_simulate_write
<<Commands: sub interfaces>>=
module subroutine cmd_simulate_write (cmd, unit, indent)
class(cmd_simulate_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_simulate_write
<<Commands: procedures>>=
module subroutine cmd_simulate_write (cmd, unit, indent)
class(cmd_simulate_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)", advance="no") "simulate ("
do i = 1, cmd%n_proc
if (i > 1) write (u, "(A,1x)", advance="no") ","
write (u, "(A)", advance="no") char (cmd%process_id(i))
end do
write (u, "(A)") ")"
end subroutine cmd_simulate_write
@ %def cmd_simulate_write
@ Compile. In contrast to WHIZARD 1 the confusing option to give the
number of unweighted events for weighted events as if unweighting were
to take place has been abandoned. (We both use [[n_events]] for
weighted and unweighted events, the variable [[n_calls]] from WHIZARD
1 has been discarded.
<<Commands: cmd simulate: TBP>>=
procedure :: compile => cmd_simulate_compile
<<Commands: sub interfaces>>=
module subroutine cmd_simulate_compile (cmd, global)
class(cmd_simulate_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_simulate_compile
<<Commands: procedures>>=
module subroutine cmd_simulate_compile (cmd, global)
class(cmd_simulate_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_proclist, pn_proc
integer :: i
pn_proclist => parse_node_get_sub_ptr (cmd%pn, 2)
cmd%pn_opt => parse_node_get_next_ptr (pn_proclist)
call cmd%compile_options (global)
cmd%n_proc = parse_node_get_n_sub (pn_proclist)
allocate (cmd%process_id (cmd%n_proc))
pn_proc => parse_node_get_sub_ptr (pn_proclist)
do i = 1, cmd%n_proc
cmd%process_id(i) = parse_node_get_string (pn_proc)
call global%process_stack%init_result_vars (cmd%process_id(i))
pn_proc => parse_node_get_next_ptr (pn_proc)
end do
end subroutine cmd_simulate_compile
@ %def cmd_simulate_compile
@ Execute command: Simulate events. This is done via a [[simulation_t]]
object and its associated methods.
Signal handling: the [[generate]] method may exit abnormally if there is a
pending signal. The current logic ensures that the [[es_array]] output
channels are closed before the [[execute]] routine returns. The program will
terminate then in [[command_list_execute]].
<<Commands: cmd simulate: TBP>>=
procedure :: execute => cmd_simulate_execute
<<Commands: sub interfaces>>=
module subroutine cmd_simulate_execute (cmd, global)
class(cmd_simulate_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_simulate_execute
<<Commands: procedures>>=
module subroutine cmd_simulate_execute (cmd, global)
class(cmd_simulate_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
type(rt_data_t), dimension(:), allocatable, target :: alt_env
integer :: n_events
type(simulation_t), target :: sim
type(event_stream_array_t) :: es_array
integer :: i, checkpoint, callback
var_list => cmd%local%var_list
if (cmd%local%nlo_fixed_order) then
call check_nlo_options (cmd%local)
end if
if (allocated (cmd%local%pn%alt_setup)) then
allocate (alt_env (size (cmd%local%pn%alt_setup)))
do i = 1, size (alt_env)
call build_alt_setup (alt_env(i), cmd%local, &
cmd%local%pn%alt_setup(i)%ptr)
end do
call sim%init (cmd%process_id, .true., .true., cmd%local, global, &
alt_env)
else
call sim%init (cmd%process_id, .true., .true., cmd%local, global)
end if
if (signal_is_pending ()) return
if (sim%is_valid ()) then
call sim%init_process_selector ()
call sim%setup_openmp ()
call sim%compute_n_events (n_events)
call sim%set_n_events_requested (n_events)
call sim%activate_extra_logging ()
call sim%prepare_event_streams (es_array)
if (es_array%is_valid ()) then
call sim%generate (es_array)
else
call sim%generate ()
end if
call es_array%final ()
if (allocated (alt_env)) then
do i = 1, size (alt_env)
call alt_env(i)%local_final ()
end do
end if
end if
call sim%final ()
end subroutine cmd_simulate_execute
@ %def cmd_simulate_execute
@ Build an alternative setup: the parse tree is stored in the global
environment. We create a temporary command list to compile and execute this;
the result is an alternative local environment [[alt_env]] which we can hand
over to the [[simulate]] command.
<<Commands: procedures>>=
recursive subroutine build_alt_setup (alt_env, global, pn)
type(rt_data_t), intent(inout), target :: alt_env
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), intent(in), target :: pn
type(command_list_t), allocatable :: alt_options
allocate (alt_options)
call alt_env%local_init (global)
call alt_env%activate ()
call alt_options%compile (pn, alt_env)
call alt_options%execute (alt_env)
call alt_env%deactivate (global, keep_local = .true.)
call alt_options%final ()
end subroutine build_alt_setup
@ %def build_alt_setup
@
\subsubsection{The rescan command}
This is the actual SINDARIN command.
<<Commands: types>>=
type, extends (command_t) :: cmd_rescan_t
! private
type(parse_node_t), pointer :: pn_filename => null ()
integer :: n_proc = 0
type(string_t), dimension(:), allocatable :: process_id
contains
<<Commands: cmd rescan: TBP>>
end type cmd_rescan_t
@ %def cmd_rescan_t
@ Output: we know the process IDs.
<<Commands: cmd rescan: TBP>>=
procedure :: write => cmd_rescan_write
<<Commands: sub interfaces>>=
module subroutine cmd_rescan_write (cmd, unit, indent)
class(cmd_rescan_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_rescan_write
<<Commands: procedures>>=
module subroutine cmd_rescan_write (cmd, unit, indent)
class(cmd_rescan_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)", advance="no") "rescan ("
do i = 1, cmd%n_proc
if (i > 1) write (u, "(A,1x)", advance="no") ","
write (u, "(A)", advance="no") char (cmd%process_id(i))
end do
write (u, "(A)") ")"
end subroutine cmd_rescan_write
@ %def cmd_rescan_write
@ Compile. The command takes a suffix argument, namely the file name
of requested event file.
<<Commands: cmd rescan: TBP>>=
procedure :: compile => cmd_rescan_compile
<<Commands: sub interfaces>>=
module subroutine cmd_rescan_compile (cmd, global)
class(cmd_rescan_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_rescan_compile
<<Commands: procedures>>=
module subroutine cmd_rescan_compile (cmd, global)
class(cmd_rescan_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_filename, pn_proclist, pn_proc
integer :: i
pn_filename => parse_node_get_sub_ptr (cmd%pn, 2)
pn_proclist => parse_node_get_next_ptr (pn_filename)
cmd%pn_opt => parse_node_get_next_ptr (pn_proclist)
call cmd%compile_options (global)
cmd%pn_filename => pn_filename
cmd%n_proc = parse_node_get_n_sub (pn_proclist)
allocate (cmd%process_id (cmd%n_proc))
pn_proc => parse_node_get_sub_ptr (pn_proclist)
do i = 1, cmd%n_proc
cmd%process_id(i) = parse_node_get_string (pn_proc)
pn_proc => parse_node_get_next_ptr (pn_proc)
end do
end subroutine cmd_rescan_compile
@ %def cmd_rescan_compile
@ Execute command: Rescan events. This is done via a [[simulation_t]]
object and its associated methods.
<<Commands: cmd rescan: TBP>>=
procedure :: execute => cmd_rescan_execute
<<Commands: sub interfaces>>=
module subroutine cmd_rescan_execute (cmd, global)
class(cmd_rescan_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_rescan_execute
<<Commands: procedures>>=
module subroutine cmd_rescan_execute (cmd, global)
class(cmd_rescan_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
type(rt_data_t), dimension(:), allocatable, target :: alt_env
type(string_t) :: sample, sample_suffix
logical :: exist, write_raw, update_event, update_sqme
type(simulation_t), target :: sim
type(event_sample_data_t) :: input_data, data
type(string_t) :: input_sample
integer :: n_fmt
type(string_t), dimension(:), allocatable :: sample_fmt
type(string_t) :: input_format, input_ext, input_file
type(string_t) :: lhef_extension, extension_hepmc, extension_lcio
type(event_stream_array_t) :: es_array
integer :: i, n_events
<<Commands: cmd rescan execute: extra variables>>
var_list => cmd%local%var_list
if (allocated (cmd%local%pn%alt_setup)) then
allocate (alt_env (size (cmd%local%pn%alt_setup)))
do i = 1, size (alt_env)
call build_alt_setup (alt_env(i), cmd%local, &
cmd%local%pn%alt_setup(i)%ptr)
end do
call sim%init (cmd%process_id, .false., .false., cmd%local, global, &
alt_env)
else
call sim%init (cmd%process_id, .false., .false., cmd%local, global)
end if
call sim%compute_n_events (n_events)
input_sample = eval_string (cmd%pn_filename, var_list)
input_format = var_list%get_sval (&
var_str ("$rescan_input_format"))
sample_suffix = ""
<<Commands: cmd rescan execute: extra init>>
sample = var_list%get_sval (var_str ("$sample"))
if (sample == "") then
sample = sim%get_default_sample_name () // sample_suffix
else
sample = var_list%get_sval (var_str ("$sample")) // sample_suffix
end if
write_raw = var_list%get_lval (var_str ("?write_raw"))
if (allocated (cmd%local%sample_fmt)) then
n_fmt = size (cmd%local%sample_fmt)
else
n_fmt = 0
end if
if (write_raw) then
if (sample == input_sample) then
call msg_error ("Rescan: ?write_raw = true: " &
// "suppressing raw event output (filename clashes with input)")
allocate (sample_fmt (n_fmt))
if (n_fmt > 0) sample_fmt = cmd%local%sample_fmt
else
allocate (sample_fmt (n_fmt + 1))
if (n_fmt > 0) sample_fmt(:n_fmt) = cmd%local%sample_fmt
sample_fmt(n_fmt+1) = var_str ("raw")
end if
else
allocate (sample_fmt (n_fmt))
if (n_fmt > 0) sample_fmt = cmd%local%sample_fmt
end if
update_event = &
var_list%get_lval (var_str ("?update_event"))
update_sqme = &
var_list%get_lval (var_str ("?update_sqme"))
if (update_event .or. update_sqme) then
call msg_message ("Recalculating observables")
if (update_sqme) then
call msg_message ("Recalculating squared matrix elements")
end if
end if
lhef_extension = &
var_list%get_sval (var_str ("$lhef_extension"))
extension_hepmc = &
var_list%get_sval (var_str ("$extension_hepmc"))
extension_lcio = &
var_list%get_sval (var_str ("$extension_lcio"))
select case (char (input_format))
case ("raw"); input_ext = "evx"
call cmd%local%set_log &
(var_str ("?recover_beams"), .false., is_known=.true.)
case ("lhef"); input_ext = lhef_extension
case ("hepmc"); input_ext = extension_hepmc
case ("lcio"); input_ext = extension_lcio
case default
call msg_fatal ("rescan: input sample format '" // char (input_format) &
// "' not supported")
end select
input_file = input_sample // "." // input_ext
inquire (file = char (input_file), exist = exist)
if (exist) then
input_data = sim%get_data (alt = .false.)
input_data%n_evt = n_events
data = sim%get_data ()
data%n_evt = n_events
input_data%md5sum_cfg = ""
call es_array%init (sample, &
sample_fmt, cmd%local, data, &
input = input_format, input_sample = input_sample, &
input_data = input_data, &
allow_switch = .false.)
call sim%rescan (n_events, es_array, global = cmd%local)
call es_array%final ()
else
call msg_fatal ("Rescan: event file '" &
// char (input_file) // "' not found")
end if
if (allocated (alt_env)) then
do i = 1, size (alt_env)
call alt_env(i)%local_final ()
end do
end if
call sim%final ()
end subroutine cmd_rescan_execute
@ %def cmd_rescan_execute
@ MPI: Append rank id to sample name.
<<Commands: cmd rescan execute: extra variables>>=
<<MPI: Commands: cmd rescan execute: extra variables>>=
logical :: mpi_logging
integer :: rank, n_size
<<Commands: cmd rescan execute: extra init>>=
<<MPI: Commands: cmd rescan execute: extra init>>=
call mpi_get_comm_id (n_size, rank)
if (n_size > 1) then
sample_suffix = var_str ("_") // str (rank)
end if
mpi_logging = (("vamp2" == char (var_list%get_sval (var_str ("$integration_method"))) &
& .and. (n_size > 1)) &
& .or. var_list%get_lval (var_str ("?mpi_logging")))
call mpi_set_logging (mpi_logging)
@
\subsubsection{Parameters: number of iterations}
Specify number of iterations and number of calls for one integration pass.
<<Commands: types>>=
type, extends (command_t) :: cmd_iterations_t
private
integer :: n_pass = 0
type(parse_node_p), dimension(:), allocatable :: pn_expr_n_it
type(parse_node_p), dimension(:), allocatable :: pn_expr_n_calls
type(parse_node_p), dimension(:), allocatable :: pn_sexpr_adapt
contains
<<Commands: cmd iterations: TBP>>
end type cmd_iterations_t
@ %def cmd_iterations_t
@ Output. Display the number of passes, which is known after compilation.
<<Commands: cmd iterations: TBP>>=
procedure :: write => cmd_iterations_write
<<Commands: sub interfaces>>=
module subroutine cmd_iterations_write (cmd, unit, indent)
class(cmd_iterations_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_iterations_write
<<Commands: procedures>>=
module subroutine cmd_iterations_write (cmd, unit, indent)
class(cmd_iterations_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
select case (cmd%n_pass)
case (0)
write (u, "(1x,A)") "iterations: [empty]"
case (1)
write (u, "(1x,A,I0,A)") "iterations: ", cmd%n_pass, " pass"
case default
write (u, "(1x,A,I0,A)") "iterations: ", cmd%n_pass, " passes"
end select
end subroutine cmd_iterations_write
@ %def cmd_iterations_write
@ Compile. Initialize evaluation trees.
<<Commands: cmd iterations: TBP>>=
procedure :: compile => cmd_iterations_compile
<<Commands: sub interfaces>>=
module subroutine cmd_iterations_compile (cmd, global)
class(cmd_iterations_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_iterations_compile
<<Commands: procedures>>=
module subroutine cmd_iterations_compile (cmd, global)
class(cmd_iterations_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_arg, pn_n_it, pn_n_calls, pn_adapt
type(parse_node_t), pointer :: pn_it_spec, pn_calls_spec, pn_adapt_spec
integer :: i
pn_arg => parse_node_get_sub_ptr (cmd%pn, 3)
if (associated (pn_arg)) then
cmd%n_pass = parse_node_get_n_sub (pn_arg)
allocate (cmd%pn_expr_n_it (cmd%n_pass))
allocate (cmd%pn_expr_n_calls (cmd%n_pass))
allocate (cmd%pn_sexpr_adapt (cmd%n_pass))
pn_it_spec => parse_node_get_sub_ptr (pn_arg)
i = 1
do while (associated (pn_it_spec))
pn_n_it => parse_node_get_sub_ptr (pn_it_spec)
pn_calls_spec => parse_node_get_next_ptr (pn_n_it)
pn_n_calls => parse_node_get_sub_ptr (pn_calls_spec, 2)
pn_adapt_spec => parse_node_get_next_ptr (pn_calls_spec)
if (associated (pn_adapt_spec)) then
pn_adapt => parse_node_get_sub_ptr (pn_adapt_spec, 2)
else
pn_adapt => null ()
end if
cmd%pn_expr_n_it(i)%ptr => pn_n_it
cmd%pn_expr_n_calls(i)%ptr => pn_n_calls
cmd%pn_sexpr_adapt(i)%ptr => pn_adapt
i = i + 1
pn_it_spec => parse_node_get_next_ptr (pn_it_spec)
end do
else
allocate (cmd%pn_expr_n_it (0))
allocate (cmd%pn_expr_n_calls (0))
end if
end subroutine cmd_iterations_compile
@ %def cmd_iterations_compile
@ Execute. Evaluate the trees and transfer the results to the iteration
list in the runtime data set.
<<Commands: cmd iterations: TBP>>=
procedure :: execute => cmd_iterations_execute
<<Commands: sub interfaces>>=
module subroutine cmd_iterations_execute (cmd, global)
class(cmd_iterations_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_iterations_execute
<<Commands: procedures>>=
module subroutine cmd_iterations_execute (cmd, global)
class(cmd_iterations_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
integer, dimension(cmd%n_pass) :: n_it, n_calls
logical, dimension(cmd%n_pass) :: custom_adapt
type(string_t), dimension(cmd%n_pass) :: adapt_code
integer :: i
var_list => global%get_var_list_ptr ()
do i = 1, cmd%n_pass
n_it(i) = eval_int (cmd%pn_expr_n_it(i)%ptr, var_list)
n_calls(i) = &
eval_int (cmd%pn_expr_n_calls(i)%ptr, var_list)
if (associated (cmd%pn_sexpr_adapt(i)%ptr)) then
adapt_code(i) = &
eval_string (cmd%pn_sexpr_adapt(i)%ptr, &
var_list, is_known = custom_adapt(i))
else
custom_adapt(i) = .false.
end if
end do
call global%it_list%init (n_it, n_calls, custom_adapt, adapt_code)
end subroutine cmd_iterations_execute
@ %def cmd_iterations_execute
@
\subsubsection{Range expressions}
We need a special type for storing and evaluating range expressions.
<<Commands: parameters>>=
integer, parameter :: STEP_NONE = 0
integer, parameter :: STEP_ADD = 1
integer, parameter :: STEP_SUB = 2
integer, parameter :: STEP_MUL = 3
integer, parameter :: STEP_DIV = 4
integer, parameter :: STEP_COMP_ADD = 11
integer, parameter :: STEP_COMP_MUL = 13
@
There is an abstract base type and two implementations: scan over integers and
scan over reals.
<<Commands: types>>=
type, abstract :: range_t
type(parse_node_t), pointer :: pn_expr => null ()
type(parse_node_t), pointer :: pn_term => null ()
type(parse_node_t), pointer :: pn_factor => null ()
type(parse_node_t), pointer :: pn_value => null ()
type(parse_node_t), pointer :: pn_literal => null ()
type(parse_node_t), pointer :: pn_beg => null ()
type(parse_node_t), pointer :: pn_end => null ()
type(parse_node_t), pointer :: pn_step => null ()
type(eval_tree_t) :: expr_beg
type(eval_tree_t) :: expr_end
type(eval_tree_t) :: expr_step
integer :: step_mode = 0
integer :: n_step = 0
contains
<<Commands: range: TBP>>
end type range_t
@ %def range_t
@ These are the implementations:
<<Commands: types>>=
type, extends (range_t) :: range_int_t
integer :: i_beg = 0
integer :: i_end = 0
integer :: i_step = 0
contains
<<Commands: range int: TBP>>
end type range_int_t
type, extends (range_t) :: range_real_t
real(default) :: r_beg = 0
real(default) :: r_end = 0
real(default) :: r_step = 0
real(default) :: lr_beg = 0
real(default) :: lr_end = 0
real(default) :: lr_step = 0
contains
<<Commands: range real: TBP>>
end type range_real_t
@ %def range_int_t range_real_t
@ Finalize the allocated dummy node. The other nodes are just pointers.
<<Commands: range: TBP>>=
procedure :: final => range_final
<<Commands: sub interfaces>>=
module subroutine range_final (object)
class(range_t), intent(inout) :: object
end subroutine range_final
<<Commands: procedures>>=
module subroutine range_final (object)
class(range_t), intent(inout) :: object
if (associated (object%pn_expr)) then
call parse_node_final (object%pn_expr, recursive = .false.)
call parse_node_final (object%pn_term, recursive = .false.)
call parse_node_final (object%pn_factor, recursive = .false.)
call parse_node_final (object%pn_value, recursive = .false.)
call parse_node_final (object%pn_literal, recursive = .false.)
deallocate (object%pn_expr)
deallocate (object%pn_term)
deallocate (object%pn_factor)
deallocate (object%pn_value)
deallocate (object%pn_literal)
end if
end subroutine range_final
@ %def range_final
@ Output.
<<Commands: range: TBP>>=
procedure (range_write), deferred :: write
procedure :: base_write => range_write
<<Commands: range int: TBP>>=
procedure :: write => range_int_write
<<Commands: range real: TBP>>=
procedure :: write => range_real_write
<<Commands: sub interfaces>>=
module subroutine range_write (object, unit)
class(range_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine range_write
module subroutine range_int_write (object, unit)
class(range_int_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine range_int_write
module subroutine range_real_write (object, unit)
class(range_real_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine range_real_write
<<Commands: procedures>>=
module subroutine range_write (object, unit)
class(range_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Range specification:"
if (associated (object%pn_expr)) then
write (u, "(1x,A)") "Dummy value:"
call parse_node_write_rec (object%pn_expr, u)
end if
if (associated (object%pn_beg)) then
write (u, "(1x,A)") "Initial value:"
call parse_node_write_rec (object%pn_beg, u)
call object%expr_beg%write (u)
if (associated (object%pn_end)) then
write (u, "(1x,A)") "Final value:"
call parse_node_write_rec (object%pn_end, u)
call object%expr_end%write (u)
if (associated (object%pn_step)) then
write (u, "(1x,A)") "Step value:"
call parse_node_write_rec (object%pn_step, u)
select case (object%step_mode)
case (STEP_ADD); write (u, "(1x,A)") "Step mode: +"
case (STEP_SUB); write (u, "(1x,A)") "Step mode: -"
case (STEP_MUL); write (u, "(1x,A)") "Step mode: *"
case (STEP_DIV); write (u, "(1x,A)") "Step mode: /"
case (STEP_COMP_ADD); write (u, "(1x,A)") "Division mode: +"
case (STEP_COMP_MUL); write (u, "(1x,A)") "Division mode: *"
end select
end if
end if
else
write (u, "(1x,A)") "Expressions: [undefined]"
end if
end subroutine range_write
module subroutine range_int_write (object, unit)
class(range_int_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
call object%base_write (unit)
write (u, "(1x,A)") "Range parameters:"
write (u, "(3x,A,I0)") "i_beg = ", object%i_beg
write (u, "(3x,A,I0)") "i_end = ", object%i_end
write (u, "(3x,A,I0)") "i_step = ", object%i_step
write (u, "(3x,A,I0)") "n_step = ", object%n_step
end subroutine range_int_write
module subroutine range_real_write (object, unit)
class(range_real_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
call object%base_write (unit)
write (u, "(1x,A)") "Range parameters:"
write (u, "(3x,A," // FMT_19 // ")") "r_beg = ", object%r_beg
write (u, "(3x,A," // FMT_19 // ")") "r_end = ", object%r_end
write (u, "(3x,A," // FMT_19 // ")") "r_step = ", object%r_end
write (u, "(3x,A,I0)") "n_step = ", object%n_step
end subroutine range_real_write
@ %def range_write
@ Initialize, given a range expression parse node. This is common to the
implementations.
<<Commands: range: TBP>>=
procedure :: init => range_init
<<Commands: sub interfaces>>=
module subroutine range_init (range, pn)
class(range_t), intent(out) :: range
type(parse_node_t), intent(in), target :: pn
end subroutine range_init
<<Commands: procedures>>=
module subroutine range_init (range, pn)
class(range_t), intent(out) :: range
type(parse_node_t), intent(in), target :: pn
type(parse_node_t), pointer :: pn_spec, pn_end, pn_step_spec, pn_op
select case (char (parse_node_get_rule_key (pn)))
case ("expr")
case ("range_expr")
range%pn_beg => parse_node_get_sub_ptr (pn)
pn_spec => parse_node_get_next_ptr (range%pn_beg)
if (associated (pn_spec)) then
pn_end => parse_node_get_sub_ptr (pn_spec, 2)
range%pn_end => pn_end
pn_step_spec => parse_node_get_next_ptr (pn_end)
if (associated (pn_step_spec)) then
pn_op => parse_node_get_sub_ptr (pn_step_spec)
range%pn_step => parse_node_get_next_ptr (pn_op)
select case (char (parse_node_get_rule_key (pn_op)))
case ("/+"); range%step_mode = STEP_ADD
case ("/-"); range%step_mode = STEP_SUB
case ("/*"); range%step_mode = STEP_MUL
case ("//"); range%step_mode = STEP_DIV
case ("/+/"); range%step_mode = STEP_COMP_ADD
case ("/*/"); range%step_mode = STEP_COMP_MUL
case default
call range%write ()
call msg_bug ("Range: step mode not implemented")
end select
else
range%step_mode = STEP_ADD
end if
else
range%step_mode = STEP_NONE
end if
call range%create_value_node ()
case default
call msg_bug ("range expression: node type '" &
// char (parse_node_get_rule_key (pn)) &
// "' not implemented")
end select
end subroutine range_init
@ %def range_init
@ This method manually creates a parse node (actually, a cascade of parse
nodes) that hold a constant value as a literal. The idea is that this node is
inserted as the right-hand side of a fake variable assignment, which is
prepended to each scan iteration. Before the variable
assignment is compiled and executed, we can manually reset the value of the
literal and thus pretend that the loop variable is assigned this value.
<<Commands: range: TBP>>=
procedure :: create_value_node => range_create_value_node
<<Commands: sub interfaces>>=
module subroutine range_create_value_node (range)
class(range_t), intent(inout) :: range
end subroutine range_create_value_node
<<Commands: procedures>>=
module subroutine range_create_value_node (range)
class(range_t), intent(inout) :: range
allocate (range%pn_literal)
allocate (range%pn_value)
select type (range)
type is (range_int_t)
call parse_node_create_value (range%pn_literal, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("integer_literal")),&
ival = 0)
call parse_node_create_branch (range%pn_value, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("integer_value")))
type is (range_real_t)
call parse_node_create_value (range%pn_literal, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("real_literal")),&
rval = 0._default)
call parse_node_create_branch (range%pn_value, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("real_value")))
class default
call msg_bug ("range: create value node: type not implemented")
end select
call parse_node_append_sub (range%pn_value, range%pn_literal)
call parse_node_freeze_branch (range%pn_value)
allocate (range%pn_factor)
call parse_node_create_branch (range%pn_factor, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("factor")))
call parse_node_append_sub (range%pn_factor, range%pn_value)
call parse_node_freeze_branch (range%pn_factor)
allocate (range%pn_term)
call parse_node_create_branch (range%pn_term, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("term")))
call parse_node_append_sub (range%pn_term, range%pn_factor)
call parse_node_freeze_branch (range%pn_term)
allocate (range%pn_expr)
call parse_node_create_branch (range%pn_expr, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("expr")))
call parse_node_append_sub (range%pn_expr, range%pn_term)
call parse_node_freeze_branch (range%pn_expr)
end subroutine range_create_value_node
@ %def range_create_value_node
@ Compile, given an environment.
<<Commands: range: TBP>>=
procedure :: compile => range_compile
<<Commands: sub interfaces>>=
module subroutine range_compile (range, global)
class(range_t), intent(inout) :: range
type(rt_data_t), intent(in), target :: global
end subroutine range_compile
<<Commands: procedures>>=
module subroutine range_compile (range, global)
class(range_t), intent(inout) :: range
type(rt_data_t), intent(in), target :: global
type(var_list_t), pointer :: var_list
var_list => global%get_var_list_ptr ()
if (associated (range%pn_beg)) then
call range%expr_beg%init_expr (range%pn_beg, var_list)
if (associated (range%pn_end)) then
call range%expr_end%init_expr (range%pn_end, var_list)
if (associated (range%pn_step)) then
call range%expr_step%init_expr (range%pn_step, var_list)
end if
end if
end if
end subroutine range_compile
@ %def range_compile
@ Evaluate: compute the actual bounds and parameters that determine the values
that we can iterate.
This is implementation-specific.
<<Commands: range: TBP>>=
procedure (range_evaluate), deferred :: evaluate
<<Commands: interfaces>>=
abstract interface
subroutine range_evaluate (range)
import
class(range_t), intent(inout) :: range
end subroutine range_evaluate
end interface
@ %def range_evaluate
@ The version for an integer variable. If the step is subtractive, we invert
the sign and treat it as an additive step. For a multiplicative step, the
step must be greater than one, and the initial and final values must be of
same sign and strictly ordered. Analogously for a division step.
<<Commands: range int: TBP>>=
procedure :: evaluate => range_int_evaluate
<<Commands: sub interfaces>>=
module subroutine range_int_evaluate (range)
class(range_int_t), intent(inout) :: range
end subroutine range_int_evaluate
<<Commands: procedures>>=
module subroutine range_int_evaluate (range)
class(range_int_t), intent(inout) :: range
integer :: ival
if (associated (range%pn_beg)) then
call range%expr_beg%evaluate ()
if (range%expr_beg%is_known ()) then
range%i_beg = range%expr_beg%get_int ()
else
call range%write ()
call msg_fatal &
("Range expression: initial value evaluates to unknown")
end if
if (associated (range%pn_end)) then
call range%expr_end%evaluate ()
if (range%expr_end%is_known ()) then
range%i_end = range%expr_end%get_int ()
if (associated (range%pn_step)) then
call range%expr_step%evaluate ()
if (range%expr_step%is_known ()) then
range%i_step = range%expr_step%get_int ()
select case (range%step_mode)
case (STEP_SUB); range%i_step = - range%i_step
end select
else
call range%write ()
call msg_fatal &
("Range expression: step value evaluates to unknown")
end if
else
range%i_step = 1
end if
else
call range%write ()
call msg_fatal &
("Range expression: final value evaluates to unknown")
end if
else
range%i_end = range%i_beg
range%i_step = 1
end if
select case (range%step_mode)
case (STEP_NONE)
range%n_step = 1
case (STEP_ADD, STEP_SUB)
if (range%i_step /= 0) then
if (range%i_beg == range%i_end) then
range%n_step = 1
else if (sign (1, range%i_end - range%i_beg) &
== sign (1, range%i_step)) then
range%n_step = (range%i_end - range%i_beg) / range%i_step + 1
else
range%n_step = 0
end if
else
call msg_fatal ("range evaluation (add): step value is zero")
end if
case (STEP_MUL)
if (range%i_step > 1) then
if (range%i_beg == range%i_end) then
range%n_step = 1
else if (range%i_beg == 0) then
call msg_fatal ("range evaluation (mul): initial value is zero")
else if (sign (1, range%i_beg) == sign (1, range%i_end) &
.and. abs (range%i_beg) < abs (range%i_end)) then
range%n_step = 0
ival = range%i_beg
do while (abs (ival) <= abs (range%i_end))
range%n_step = range%n_step + 1
ival = ival * range%i_step
end do
else
range%n_step = 0
end if
else
call msg_fatal &
("range evaluation (mult): step value is one or less")
end if
case (STEP_DIV)
if (range%i_step > 1) then
if (range%i_beg == range%i_end) then
range%n_step = 1
else if (sign (1, range%i_beg) == sign (1, range%i_end) &
.and. abs (range%i_beg) > abs (range%i_end)) then
range%n_step = 0
ival = range%i_beg
do while (abs (ival) >= abs (range%i_end))
range%n_step = range%n_step + 1
if (ival == 0) exit
ival = ival / range%i_step
end do
else
range%n_step = 0
end if
else
call msg_fatal &
("range evaluation (div): step value is one or less")
end if
case (STEP_COMP_ADD)
call msg_fatal ("range evaluation: &
&step mode /+/ not allowed for integer variable")
case (STEP_COMP_MUL)
call msg_fatal ("range evaluation: &
&step mode /*/ not allowed for integer variable")
case default
call range%write ()
call msg_bug ("range evaluation: step mode not implemented")
end select
end if
end subroutine range_int_evaluate
@ %def range_int_evaluate
@ The version for a real variable.
<<Commands: range real: TBP>>=
procedure :: evaluate => range_real_evaluate
<<Commands: sub interfaces>>=
module subroutine range_real_evaluate (range)
class(range_real_t), intent(inout) :: range
end subroutine range_real_evaluate
<<Commands: procedures>>=
module subroutine range_real_evaluate (range)
class(range_real_t), intent(inout) :: range
if (associated (range%pn_beg)) then
call range%expr_beg%evaluate ()
if (range%expr_beg%is_known ()) then
range%r_beg = range%expr_beg%get_real ()
else
call range%write ()
call msg_fatal &
("Range expression: initial value evaluates to unknown")
end if
if (associated (range%pn_end)) then
call range%expr_end%evaluate ()
if (range%expr_end%is_known ()) then
range%r_end = range%expr_end%get_real ()
if (associated (range%pn_step)) then
if (range%expr_step%is_known ()) then
select case (range%step_mode)
case (STEP_ADD, STEP_SUB, STEP_MUL, STEP_DIV)
call range%expr_step%evaluate ()
range%r_step = range%expr_step%get_real ()
select case (range%step_mode)
case (STEP_SUB); range%r_step = - range%r_step
end select
case (STEP_COMP_ADD, STEP_COMP_MUL)
range%n_step = &
max (range%expr_step%get_int (), 0)
end select
else
call range%write ()
call msg_fatal &
("Range expression: step value evaluates to unknown")
end if
else
call range%write ()
call msg_fatal &
("Range expression (real): step value must be provided")
end if
else
call range%write ()
call msg_fatal &
("Range expression: final value evaluates to unknown")
end if
else
range%r_end = range%r_beg
range%r_step = 1
end if
select case (range%step_mode)
case (STEP_NONE)
range%n_step = 1
case (STEP_ADD, STEP_SUB)
if (range%r_step /= 0) then
if (sign (1._default, range%r_end - range%r_beg) &
== sign (1._default, range%r_step)) then
range%n_step = &
nint ((range%r_end - range%r_beg) / range%r_step + 1)
else
range%n_step = 0
end if
else
call msg_fatal ("range evaluation (add): step value is zero")
end if
case (STEP_MUL)
if (range%r_step > 1) then
if (range%r_beg == 0 .or. range%r_end == 0) then
call msg_fatal ("range evaluation (mul): bound is zero")
else if (sign (1._default, range%r_beg) &
== sign (1._default, range%r_end) &
.and. abs (range%r_beg) <= abs (range%r_end)) then
range%lr_beg = log (abs (range%r_beg))
range%lr_end = log (abs (range%r_end))
range%lr_step = log (range%r_step)
range%n_step = nint &
(abs ((range%lr_end - range%lr_beg) / range%lr_step) + 1)
else
range%n_step = 0
end if
else
call msg_fatal &
("range evaluation (mult): step value is one or less")
end if
case (STEP_DIV)
if (range%r_step > 1) then
if (range%r_beg == 0 .or. range%r_end == 0) then
call msg_fatal ("range evaluation (div): bound is zero")
else if (sign (1._default, range%r_beg) &
== sign (1._default, range%r_end) &
.and. abs (range%r_beg) >= abs (range%r_end)) then
range%lr_beg = log (abs (range%r_beg))
range%lr_end = log (abs (range%r_end))
range%lr_step = -log (range%r_step)
range%n_step = nint &
(abs ((range%lr_end - range%lr_beg) / range%lr_step) + 1)
else
range%n_step = 0
end if
else
call msg_fatal &
("range evaluation (mult): step value is one or less")
end if
case (STEP_COMP_ADD)
! Number of steps already known
case (STEP_COMP_MUL)
! Number of steps already known
if (range%r_beg == 0 .or. range%r_end == 0) then
call msg_fatal ("range evaluation (mul): bound is zero")
else if (sign (1._default, range%r_beg) &
== sign (1._default, range%r_end)) then
range%lr_beg = log (abs (range%r_beg))
range%lr_end = log (abs (range%r_end))
else
range%n_step = 0
end if
case default
call range%write ()
call msg_bug ("range evaluation: step mode not implemented")
end select
end if
end subroutine range_real_evaluate
@ %def range_real_evaluate
@ Return the number of iterations:
<<Commands: range: TBP>>=
procedure :: get_n_iterations => range_get_n_iterations
<<Commands: sub interfaces>>=
module function range_get_n_iterations (range) result (n)
class(range_t), intent(in) :: range
integer :: n
end function range_get_n_iterations
<<Commands: procedures>>=
module function range_get_n_iterations (range) result (n)
class(range_t), intent(in) :: range
integer :: n
n = range%n_step
end function range_get_n_iterations
@ %def range_get_n_iterations
@ Compute the value for iteration [[i]] and store it in the embedded token.
<<Commands: range: TBP>>=
procedure (range_set_value), deferred :: set_value
<<Commands: interfaces>>=
abstract interface
subroutine range_set_value (range, i)
import
class(range_t), intent(inout) :: range
integer, intent(in) :: i
end subroutine range_set_value
end interface
@ %def range_set_value
@ In the integer case, we compute the value directly for additive step. For
multiplicative step, we perform a loop in the same way as above, where the
number of iteration was determined.
<<Commands: range int: TBP>>=
procedure :: set_value => range_int_set_value
<<Commands: sub interfaces>>=
module subroutine range_int_set_value (range, i)
class(range_int_t), intent(inout) :: range
integer, intent(in) :: i
end subroutine range_int_set_value
<<Commands: procedures>>=
module subroutine range_int_set_value (range, i)
class(range_int_t), intent(inout) :: range
integer, intent(in) :: i
integer :: k, ival
select case (range%step_mode)
case (STEP_NONE)
ival = range%i_beg
case (STEP_ADD, STEP_SUB)
ival = range%i_beg + (i - 1) * range%i_step
case (STEP_MUL)
ival = range%i_beg
do k = 1, i - 1
ival = ival * range%i_step
end do
case (STEP_DIV)
ival = range%i_beg
do k = 1, i - 1
ival = ival / range%i_step
end do
case default
call range%write ()
call msg_bug ("range iteration: step mode not implemented")
end select
call parse_node_set_value (range%pn_literal, ival = ival)
end subroutine range_int_set_value
@ %def range_int_set_value
@ In the integer case, we compute the value directly for additive step. For
multiplicative step, we perform a loop in the same way as above, where the
number of iteration was determined.
<<Commands: range real: TBP>>=
procedure :: set_value => range_real_set_value
<<Commands: sub interfaces>>=
module subroutine range_real_set_value (range, i)
class(range_real_t), intent(inout) :: range
integer, intent(in) :: i
end subroutine range_real_set_value
<<Commands: procedures>>=
module subroutine range_real_set_value (range, i)
class(range_real_t), intent(inout) :: range
integer, intent(in) :: i
real(default) :: rval, x
select case (range%step_mode)
case (STEP_NONE)
rval = range%r_beg
case (STEP_ADD, STEP_SUB, STEP_COMP_ADD)
if (range%n_step > 1) then
x = real (i - 1, default) / (range%n_step - 1)
else
x = 1._default / 2
end if
rval = x * range%r_end + (1 - x) * range%r_beg
case (STEP_MUL, STEP_DIV, STEP_COMP_MUL)
if (range%n_step > 1) then
x = real (i - 1, default) / (range%n_step - 1)
else
x = 1._default / 2
end if
rval = sign &
(exp (x * range%lr_end + (1 - x) * range%lr_beg), range%r_beg)
case default
call range%write ()
call msg_bug ("range iteration: step mode not implemented")
end select
call parse_node_set_value (range%pn_literal, rval = rval)
end subroutine range_real_set_value
@ %def range_real_set_value
@
\subsubsection{Scan over parameters and other objects}
The scan command allocates a new parse node for the variable
assignment (the lhs). The rhs of this parse node is assigned from the
available rhs expressions in the scan list, one at a time, so the
compiled parse node can be prepended to the scan body.
<<Commands: types>>=
type, extends (command_t) :: cmd_scan_t
private
type(string_t) :: name
integer :: n_values = 0
type(parse_node_p), dimension(:), allocatable :: scan_cmd
class(range_t), dimension(:), allocatable :: range
contains
<<Commands: cmd scan: TBP>>
end type cmd_scan_t
@ %def cmd_scan_t
@ Finalizer.
The auxiliary parse nodes that we have constructed have to be treated
carefully: the embedded pointers all point to persistent objects
somewhere else and should not be finalized, so we should not call the
finalizer recursively.
<<Commands: cmd scan: TBP>>=
procedure :: final => cmd_scan_final
<<Commands: sub interfaces>>=
recursive module subroutine cmd_scan_final (cmd)
class(cmd_scan_t), intent(inout) :: cmd
end subroutine cmd_scan_final
<<Commands: procedures>>=
recursive module subroutine cmd_scan_final (cmd)
class(cmd_scan_t), intent(inout) :: cmd
type(parse_node_t), pointer :: pn_var_single, pn_decl_single
type(string_t) :: key
integer :: i
if (allocated (cmd%scan_cmd)) then
do i = 1, size (cmd%scan_cmd)
pn_var_single => parse_node_get_sub_ptr (cmd%scan_cmd(i)%ptr)
key = parse_node_get_rule_key (pn_var_single)
select case (char (key))
case ("scan_string_decl", "scan_log_decl")
pn_decl_single => parse_node_get_sub_ptr (pn_var_single, 2)
call parse_node_final (pn_decl_single, recursive=.false.)
deallocate (pn_decl_single)
end select
call parse_node_final (pn_var_single, recursive=.false.)
deallocate (pn_var_single)
end do
deallocate (cmd%scan_cmd)
end if
if (allocated (cmd%range)) then
do i = 1, size (cmd%range)
call cmd%range(i)%final ()
end do
end if
end subroutine cmd_scan_final
@ %def cmd_scan_final
@ Output.
<<Commands: cmd scan: TBP>>=
procedure :: write => cmd_scan_write
<<Commands: sub interfaces>>=
module subroutine cmd_scan_write (cmd, unit, indent)
class(cmd_scan_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_scan_write
<<Commands: procedures>>=
module subroutine cmd_scan_write (cmd, unit, indent)
class(cmd_scan_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,1x,A,1x,'(',I0,')')") "scan:", char (cmd%name), &
cmd%n_values
end subroutine cmd_scan_write
@ %def cmd_scan_write
@ Compile the scan command. We construct a new parse node that
implements the variable assignment for a single element on the rhs,
instead of the whole list that we get from the original parse tree.
By simply copying the node, we copy all pointers and inherit the
targets from the original. During execution, we should replace the
rhs by the stored rhs pointers (the list elements), one by one, then
(re)compile the redefined node.
Gfortran 7/8/9 bug, has to remain in the main module:
<<Commands: cmd scan: TBP>>=
procedure :: compile => cmd_scan_compile
<<Commands: main procedures>>=
recursive subroutine cmd_scan_compile (cmd, global)
class(cmd_scan_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
type(parse_node_t), pointer :: pn_var, pn_body, pn_body_first
type(parse_node_t), pointer :: pn_decl, pn_name
type(parse_node_t), pointer :: pn_arg, pn_scan_cmd, pn_rhs
type(parse_node_t), pointer :: pn_decl_single, pn_var_single
type(syntax_rule_t), pointer :: var_rule_decl, var_rule
type(string_t) :: key
integer :: var_type
integer :: i
if (debug_on) call msg_debug (D_CORE, "cmd_scan_compile")
if (debug_active (D_CORE)) call parse_node_write_rec (cmd%pn)
pn_var => parse_node_get_sub_ptr (cmd%pn, 2)
pn_body => parse_node_get_next_ptr (pn_var)
if (associated (pn_body)) then
pn_body_first => parse_node_get_sub_ptr (pn_body)
else
pn_body_first => null ()
end if
key = parse_node_get_rule_key (pn_var)
select case (char (key))
case ("scan_num")
pn_name => parse_node_get_sub_ptr (pn_var)
cmd%name = parse_node_get_string (pn_name)
var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_num"))
pn_arg => parse_node_get_next_ptr (pn_name, 2)
case ("scan_int")
pn_name => parse_node_get_sub_ptr (pn_var, 2)
cmd%name = parse_node_get_string (pn_name)
var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_int"))
pn_arg => parse_node_get_next_ptr (pn_name, 2)
case ("scan_real")
pn_name => parse_node_get_sub_ptr (pn_var, 2)
cmd%name = parse_node_get_string (pn_name)
var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_real"))
pn_arg => parse_node_get_next_ptr (pn_name, 2)
case ("scan_complex")
pn_name => parse_node_get_sub_ptr (pn_var, 2)
cmd%name = parse_node_get_string (pn_name)
var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str("cmd_complex"))
pn_arg => parse_node_get_next_ptr (pn_name, 2)
case ("scan_alias")
pn_name => parse_node_get_sub_ptr (pn_var, 2)
cmd%name = parse_node_get_string (pn_name)
var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_alias"))
pn_arg => parse_node_get_next_ptr (pn_name, 2)
case ("scan_string_decl")
pn_decl => parse_node_get_sub_ptr (pn_var, 2)
pn_name => parse_node_get_sub_ptr (pn_decl, 2)
cmd%name = parse_node_get_string (pn_name)
var_rule_decl => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_string"))
var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_string_decl"))
pn_arg => parse_node_get_next_ptr (pn_name, 2)
case ("scan_log_decl")
pn_decl => parse_node_get_sub_ptr (pn_var, 2)
pn_name => parse_node_get_sub_ptr (pn_decl, 2)
cmd%name = parse_node_get_string (pn_name)
var_rule_decl => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_log"))
var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_log_decl"))
pn_arg => parse_node_get_next_ptr (pn_name, 2)
case ("scan_cuts")
var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_cuts"))
cmd%name = "cuts"
pn_arg => parse_node_get_sub_ptr (pn_var, 3)
case ("scan_weight")
var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_weight"))
cmd%name = "weight"
pn_arg => parse_node_get_sub_ptr (pn_var, 3)
case ("scan_scale")
var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_scale"))
cmd%name = "scale"
pn_arg => parse_node_get_sub_ptr (pn_var, 3)
case ("scan_ren_scale")
var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_ren_scale"))
cmd%name = "renormalization_scale"
pn_arg => parse_node_get_sub_ptr (pn_var, 3)
case ("scan_fac_scale")
var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_fac_scale"))
cmd%name = "factorization_scale"
pn_arg => parse_node_get_sub_ptr (pn_var, 3)
case ("scan_selection")
var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_selection"))
cmd%name = "selection"
pn_arg => parse_node_get_sub_ptr (pn_var, 3)
case ("scan_reweight")
var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_reweight"))
cmd%name = "reweight"
pn_arg => parse_node_get_sub_ptr (pn_var, 3)
case ("scan_analysis")
var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_analysis"))
cmd%name = "analysis"
pn_arg => parse_node_get_sub_ptr (pn_var, 3)
case ("scan_model")
var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_model"))
cmd%name = "model"
pn_arg => parse_node_get_sub_ptr (pn_var, 3)
case ("scan_library")
var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
var_str ("cmd_library"))
cmd%name = "library"
pn_arg => parse_node_get_sub_ptr (pn_var, 3)
case default
call msg_bug ("scan: case '" // char (key) // "' not implemented")
end select
if (associated (pn_arg)) then
cmd%n_values = parse_node_get_n_sub (pn_arg)
end if
var_list => global%get_var_list_ptr ()
allocate (cmd%scan_cmd (cmd%n_values))
select case (char (key))
case ("scan_num")
var_type = &
var_list%get_type (cmd%name)
select case (var_type)
case (V_INT)
allocate (range_int_t :: cmd%range (cmd%n_values))
case (V_REAL)
allocate (range_real_t :: cmd%range (cmd%n_values))
case (V_CMPLX)
call msg_fatal ("scan over complex variable not implemented")
case (V_NONE)
call msg_fatal ("scan: variable '" // char (cmd%name) //"' undefined")
case default
call msg_bug ("scan: impossible variable type")
end select
case ("scan_int")
allocate (range_int_t :: cmd%range (cmd%n_values))
case ("scan_real")
allocate (range_real_t :: cmd%range (cmd%n_values))
case ("scan_complex")
call msg_fatal ("scan over complex variable not implemented")
end select
i = 1
if (associated (pn_arg)) then
pn_rhs => parse_node_get_sub_ptr (pn_arg)
else
pn_rhs => null ()
end if
do while (associated (pn_rhs))
allocate (pn_scan_cmd)
call parse_node_create_branch (pn_scan_cmd, &
syntax_get_rule_ptr (syntax_cmd_list, var_str ("command_list")))
allocate (pn_var_single)
pn_var_single = pn_var
call parse_node_replace_rule (pn_var_single, var_rule)
select case (char (key))
case ("scan_num", "scan_int", "scan_real", &
"scan_complex", "scan_alias", &
"scan_cuts", "scan_weight", &
"scan_scale", "scan_ren_scale", "scan_fac_scale", &
"scan_selection", "scan_reweight", "scan_analysis", &
"scan_model", "scan_library")
if (allocated (cmd%range)) then
call cmd%range(i)%init (pn_rhs)
call parse_node_replace_last_sub &
(pn_var_single, cmd%range(i)%pn_expr)
else
call parse_node_replace_last_sub (pn_var_single, pn_rhs)
end if
case ("scan_string_decl", "scan_log_decl")
allocate (pn_decl_single)
pn_decl_single = pn_decl
call parse_node_replace_rule (pn_decl_single, var_rule_decl)
call parse_node_replace_last_sub (pn_decl_single, pn_rhs)
call parse_node_freeze_branch (pn_decl_single)
call parse_node_replace_last_sub (pn_var_single, pn_decl_single)
case default
call msg_bug ("scan: case '" // char (key) &
// "' broken")
end select
call parse_node_freeze_branch (pn_var_single)
call parse_node_append_sub (pn_scan_cmd, pn_var_single)
call parse_node_append_sub (pn_scan_cmd, pn_body_first)
call parse_node_freeze_branch (pn_scan_cmd)
cmd%scan_cmd(i)%ptr => pn_scan_cmd
i = i + 1
pn_rhs => parse_node_get_next_ptr (pn_rhs)
end do
if (debug_active (D_CORE)) then
do i = 1, cmd%n_values
print *, "scan command ", i
call parse_node_write_rec (cmd%scan_cmd(i)%ptr)
if (allocated (cmd%range)) call cmd%range(i)%write ()
end do
print *, "original"
call parse_node_write_rec (cmd%pn)
end if
end subroutine cmd_scan_compile
@ %def cmd_scan_compile
@ Execute the loop for all values in the step list. We use the
parse trees with single variable assignment that we have stored, to
iteratively create a local environment, execute the stored commands, and
destroy it again. When we encounter a range object, we execute the commands
for each value that this object provides. Computing this value has the side
effect of modifying the rhs of the variable assignment that heads the local
command list, directly in the local parse tree.
<<Commands: cmd scan: TBP>>=
procedure :: execute => cmd_scan_execute
<<Commands: sub interfaces>>=
recursive module subroutine cmd_scan_execute (cmd, global)
class(cmd_scan_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_scan_execute
<<Commands: procedures>>=
recursive module subroutine cmd_scan_execute (cmd, global)
class(cmd_scan_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(rt_data_t), allocatable :: local
integer :: i, j
do i = 1, cmd%n_values
if (allocated (cmd%range)) then
call cmd%range(i)%compile (global)
call cmd%range(i)%evaluate ()
do j = 1, cmd%range(i)%get_n_iterations ()
call cmd%range(i)%set_value (j)
allocate (local)
call build_alt_setup (local, global, cmd%scan_cmd(i)%ptr)
call local%local_final ()
deallocate (local)
end do
else
allocate (local)
call build_alt_setup (local, global, cmd%scan_cmd(i)%ptr)
call local%local_final ()
deallocate (local)
end if
end do
end subroutine cmd_scan_execute
@ %def cmd_scan_execute
@
\subsubsection{Conditionals}
Conditionals are implemented as a list that is compiled and evaluated
recursively; this allows for a straightforward representation of
[[else if]] constructs. A [[cmd_if_t]] object can hold either an
[[else_if]] clause which is another object of this type, or an
[[else_body]], but not both.
If- or else-bodies are no scoping units, so all data remain global and
no copy-in copy-out is needed.
<<Commands: types>>=
type, extends (command_t) :: cmd_if_t
private
type(parse_node_t), pointer :: pn_if_lexpr => null ()
type(command_list_t), pointer :: if_body => null ()
type(cmd_if_t), dimension(:), pointer :: elsif_cmd => null ()
type(command_list_t), pointer :: else_body => null ()
contains
<<Commands: cmd if: TBP>>
end type cmd_if_t
@ %def cmd_if_t
@ Finalizer. There are no local options, therefore we can simply override
the default finalizer.
<<Commands: cmd if: TBP>>=
procedure :: final => cmd_if_final
<<Commands: sub interfaces>>=
recursive module subroutine cmd_if_final (cmd)
class(cmd_if_t), intent(inout) :: cmd
end subroutine cmd_if_final
<<Commands: procedures>>=
recursive module subroutine cmd_if_final (cmd)
class(cmd_if_t), intent(inout) :: cmd
integer :: i
if (associated (cmd%if_body)) then
call command_list_final (cmd%if_body)
deallocate (cmd%if_body)
end if
if (associated (cmd%elsif_cmd)) then
do i = 1, size (cmd%elsif_cmd)
call cmd_if_final (cmd%elsif_cmd(i))
end do
deallocate (cmd%elsif_cmd)
end if
if (associated (cmd%else_body)) then
call command_list_final (cmd%else_body)
deallocate (cmd%else_body)
end if
end subroutine cmd_if_final
@ %def cmd_if_final
@ Output. Recursively write the command lists.
<<Commands: cmd if: TBP>>=
procedure :: write => cmd_if_write
<<Commands: sub interfaces>>=
module subroutine cmd_if_write (cmd, unit, indent)
class(cmd_if_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_if_write
<<Commands: procedures>>=
module subroutine cmd_if_write (cmd, unit, indent)
class(cmd_if_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u, ind, i
u = given_output_unit (unit); if (u < 0) return
ind = 0; if (present (indent)) ind = indent
call write_indent (u, indent)
write (u, "(A)") "if <expr> then"
if (associated (cmd%if_body)) then
call cmd%if_body%write (unit, ind + 1)
end if
if (associated (cmd%elsif_cmd)) then
do i = 1, size (cmd%elsif_cmd)
call write_indent (u, indent)
write (u, "(A)") "elsif <expr> then"
if (associated (cmd%elsif_cmd(i)%if_body)) then
call cmd%elsif_cmd(i)%if_body%write (unit, ind + 1)
end if
end do
end if
if (associated (cmd%else_body)) then
call write_indent (u, indent)
write (u, "(A)") "else"
call cmd%else_body%write (unit, ind + 1)
end if
end subroutine cmd_if_write
@ %def cmd_if_write
@ Compile the conditional.
<<Commands: cmd if: TBP>>=
procedure :: compile => cmd_if_compile
<<Commands: sub interfaces>>=
recursive module subroutine cmd_if_compile (cmd, global)
class(cmd_if_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_if_compile
<<Commands: procedures>>=
recursive module subroutine cmd_if_compile (cmd, global)
class(cmd_if_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_lexpr, pn_body
type(parse_node_t), pointer :: pn_elsif_clauses, pn_cmd_elsif
type(parse_node_t), pointer :: pn_else_clause, pn_cmd_else
integer :: i, n_elsif
pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 2)
cmd%pn_if_lexpr => pn_lexpr
pn_body => parse_node_get_next_ptr (pn_lexpr, 2)
select case (char (parse_node_get_rule_key (pn_body)))
case ("command_list")
allocate (cmd%if_body)
call cmd%if_body%compile (pn_body, global)
pn_elsif_clauses => parse_node_get_next_ptr (pn_body)
case default
pn_elsif_clauses => pn_body
end select
select case (char (parse_node_get_rule_key (pn_elsif_clauses)))
case ("elsif_clauses")
n_elsif = parse_node_get_n_sub (pn_elsif_clauses)
allocate (cmd%elsif_cmd (n_elsif))
pn_cmd_elsif => parse_node_get_sub_ptr (pn_elsif_clauses)
do i = 1, n_elsif
pn_lexpr => parse_node_get_sub_ptr (pn_cmd_elsif, 2)
cmd%elsif_cmd(i)%pn_if_lexpr => pn_lexpr
pn_body => parse_node_get_next_ptr (pn_lexpr, 2)
if (associated (pn_body)) then
allocate (cmd%elsif_cmd(i)%if_body)
call cmd%elsif_cmd(i)%if_body%compile (pn_body, global)
end if
pn_cmd_elsif => parse_node_get_next_ptr (pn_cmd_elsif)
end do
pn_else_clause => parse_node_get_next_ptr (pn_elsif_clauses)
case default
pn_else_clause => pn_elsif_clauses
end select
select case (char (parse_node_get_rule_key (pn_else_clause)))
case ("else_clause")
pn_cmd_else => parse_node_get_sub_ptr (pn_else_clause)
pn_body => parse_node_get_sub_ptr (pn_cmd_else, 2)
if (associated (pn_body)) then
allocate (cmd%else_body)
call cmd%else_body%compile (pn_body, global)
end if
end select
end subroutine cmd_if_compile
@ %def global
@ (Recursively) execute the condition. Context remains global in all cases.
<<Commands: cmd if: TBP>>=
procedure :: execute => cmd_if_execute
<<Commands: sub interfaces>>=
recursive module subroutine cmd_if_execute (cmd, global)
class(cmd_if_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_if_execute
<<Commands: procedures>>=
recursive module subroutine cmd_if_execute (cmd, global)
class(cmd_if_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
logical :: lval, is_known
integer :: i
var_list => global%get_var_list_ptr ()
lval = eval_log (cmd%pn_if_lexpr, var_list, is_known=is_known)
if (is_known) then
if (lval) then
if (associated (cmd%if_body)) then
call cmd%if_body%execute (global)
end if
return
end if
else
call error_undecided ()
return
end if
if (associated (cmd%elsif_cmd)) then
SCAN_ELSIF: do i = 1, size (cmd%elsif_cmd)
lval = eval_log (cmd%elsif_cmd(i)%pn_if_lexpr, var_list, &
is_known=is_known)
if (is_known) then
if (lval) then
if (associated (cmd%elsif_cmd(i)%if_body)) then
call cmd%elsif_cmd(i)%if_body%execute (global)
end if
return
end if
else
call error_undecided ()
return
end if
end do SCAN_ELSIF
end if
if (associated (cmd%else_body)) then
call cmd%else_body%execute (global)
end if
contains
subroutine error_undecided ()
call msg_error ("Undefined result of cmditional expression: " &
// "neither branch will be executed")
end subroutine error_undecided
end subroutine cmd_if_execute
@ %def cmd_if_execute
@
\subsubsection{Include another command-list file}
The include command allocates a local parse tree. This must not be
deleted before the command object itself is deleted, since pointers
may point to subobjects of it.
<<Commands: types>>=
type, extends (command_t) :: cmd_include_t
private
type(string_t) :: file
type(command_list_t), pointer :: command_list => null ()
type(parse_tree_t) :: parse_tree
contains
<<Commands: cmd include: TBP>>
end type cmd_include_t
@ %def cmd_include_t
@ Finalizer: delete the command list. No options, so we can simply override
the default finalizer.
<<Commands: cmd include: TBP>>=
procedure :: final => cmd_include_final
<<Commands: sub interfaces>>=
module subroutine cmd_include_final (cmd)
class(cmd_include_t), intent(inout) :: cmd
end subroutine cmd_include_final
<<Commands: procedures>>=
module subroutine cmd_include_final (cmd)
class(cmd_include_t), intent(inout) :: cmd
call parse_tree_final (cmd%parse_tree)
if (associated (cmd%command_list)) then
call cmd%command_list%final ()
deallocate (cmd%command_list)
end if
end subroutine cmd_include_final
@ %def cmd_include_final
@ Write: display the command list as-is, if allocated.
<<Commands: cmd include: TBP>>=
procedure :: write => cmd_include_write
<<Commands: sub interfaces>>=
module subroutine cmd_include_write (cmd, unit, indent)
class(cmd_include_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_include_write
<<Commands: procedures>>=
module subroutine cmd_include_write (cmd, unit, indent)
class(cmd_include_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u, ind
u = given_output_unit (unit)
ind = 0; if (present (indent)) ind = indent
call write_indent (u, indent)
write (u, "(A,A,A,A)") "include ", '"', char (cmd%file), '"'
if (associated (cmd%command_list)) then
call cmd%command_list%write (u, ind + 1)
end if
end subroutine cmd_include_write
@ %def cmd_include_write
@ Compile file contents: First parse the file, then immediately
compile its contents. Use the global data set.
<<Commands: cmd include: TBP>>=
procedure :: compile => cmd_include_compile
<<Commands: sub interfaces>>=
module subroutine cmd_include_compile (cmd, global)
class(cmd_include_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_include_compile
<<Commands: procedures>>=
module subroutine cmd_include_compile (cmd, global)
class(cmd_include_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_arg, pn_file
type(string_t) :: file
logical :: exist
integer :: u
type(stream_t), target :: stream
type(lexer_t) :: lexer
pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
pn_file => parse_node_get_sub_ptr (pn_arg)
file = parse_node_get_string (pn_file)
inquire (file=char(file), exist=exist)
if (exist) then
cmd%file = file
else
cmd%file = global%os_data%whizard_cutspath // "/" // file
inquire (file=char(cmd%file), exist=exist)
if (.not. exist) then
call msg_error ("Include file '" // char (file) // "' not found")
return
end if
end if
u = free_unit ()
call lexer_init_cmd_list (lexer, global%lexer)
call stream_init (stream, char (cmd%file))
call lexer_assign_stream (lexer, stream)
call parse_tree_init (cmd%parse_tree, syntax_cmd_list, lexer)
call stream_final (stream)
call lexer_final (lexer)
close (u)
allocate (cmd%command_list)
call cmd%command_list%compile (cmd%parse_tree%get_root_ptr (), &
global)
end subroutine cmd_include_compile
@ %def cmd_include_compile
@ Execute file contents in the global context.
<<Commands: cmd include: TBP>>=
procedure :: execute => cmd_include_execute
<<Commands: sub interfaces>>=
module subroutine cmd_include_execute (cmd, global)
class(cmd_include_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_include_execute
<<Commands: procedures>>=
module subroutine cmd_include_execute (cmd, global)
class(cmd_include_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
if (associated (cmd%command_list)) then
call msg_message &
("Including Sindarin from '" // char (cmd%file) // "'")
call cmd%command_list%execute (global)
call msg_message &
("End of included '" // char (cmd%file) // "'")
end if
end subroutine cmd_include_execute
@ %def cmd_include_execute
@
\subsubsection{Export values}
This command exports the current values of variables or other objects to the
surrounding scope. By default, a scope enclosed by braces keeps all objects
local to it. The [[export]] command exports the values that are generated
within the scope to the corresponding object in the outer scope.
The allowed set of exportable objects is, in principle, the same as the set of
objects that the [[show]] command supports. This includes some convenience
abbreviations.
TODO: The initial implementation inherits syntax from [[show]], but supports
only the [[results]] pseudo-object. The results (i.e., the process stack) is
appended to the outer process stack instead of being discarded. The behavior
of the [[export]] command for other object kinds is to be defined on a
case-by-case basis. It may involve replacing the outer value or, instead,
doing some sort of appending or reduction.
<<Commands: types>>=
type, extends (command_t) :: cmd_export_t
private
type(string_t), dimension(:), allocatable :: name
contains
<<Commands: cmd export: TBP>>
end type cmd_export_t
@ %def cmd_export_t
@ Output: list the object names, not values.
<<Commands: cmd export: TBP>>=
procedure :: write => cmd_export_write
<<Commands: sub interfaces>>=
module subroutine cmd_export_write (cmd, unit, indent)
class(cmd_export_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_export_write
<<Commands: procedures>>=
module subroutine cmd_export_write (cmd, unit, indent)
class(cmd_export_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A)", advance="no") "export: "
if (allocated (cmd%name)) then
do i = 1, size (cmd%name)
write (u, "(1x,A)", advance="no") char (cmd%name(i))
end do
write (u, *)
else
write (u, "(5x,A)") "[undefined]"
end if
end subroutine cmd_export_write
@ %def cmd_export_write
@ Compile. Allocate an array which is filled with the names of the
variables to export.
<<Commands: cmd export: TBP>>=
procedure :: compile => cmd_export_compile
<<Commands: sub interfaces>>=
module subroutine cmd_export_compile (cmd, global)
class(cmd_export_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_export_compile
<<Commands: procedures>>=
module subroutine cmd_export_compile (cmd, global)
class(cmd_export_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name
type(string_t) :: key
integer :: i, n_args
pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
if (associated (pn_arg)) then
select case (char (parse_node_get_rule_key (pn_arg)))
case ("show_arg")
cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
case default
cmd%pn_opt => pn_arg
pn_arg => null ()
end select
end if
call cmd%compile_options (global)
if (associated (pn_arg)) then
n_args = parse_node_get_n_sub (pn_arg)
allocate (cmd%name (n_args))
pn_var => parse_node_get_sub_ptr (pn_arg)
i = 0
do while (associated (pn_var))
i = i + 1
select case (char (parse_node_get_rule_key (pn_var)))
case ("model", "library", "beams", "iterations", &
"cuts", "weight", "int", "real", "complex", &
"scale", "factorization_scale", "renormalization_scale", &
"selection", "reweight", "analysis", "pdg", &
"stable", "unstable", "polarized", "unpolarized", &
"results", "expect", "intrinsic", "string", "logical")
cmd%name(i) = parse_node_get_key (pn_var)
case ("result_var")
pn_prefix => parse_node_get_sub_ptr (pn_var)
pn_name => parse_node_get_next_ptr (pn_prefix)
if (associated (pn_name)) then
cmd%name(i) = parse_node_get_key (pn_prefix) &
// "(" // parse_node_get_string (pn_name) // ")"
else
cmd%name(i) = parse_node_get_key (pn_prefix)
end if
case ("log_var", "string_var", "alias_var")
pn_prefix => parse_node_get_sub_ptr (pn_var)
pn_name => parse_node_get_next_ptr (pn_prefix)
key = parse_node_get_key (pn_prefix)
if (associated (pn_name)) then
select case (char (parse_node_get_rule_key (pn_name)))
case ("var_name")
select case (char (key))
case ("?", "$") ! $ sign
cmd%name(i) = key // parse_node_get_string (pn_name)
case ("alias")
cmd%name(i) = parse_node_get_string (pn_name)
end select
case default
call parse_node_mismatch &
("var_name", pn_name)
end select
else
cmd%name(i) = key
end if
case default
cmd%name(i) = parse_node_get_string (pn_var)
end select
!!! restriction imposed by current lack of implementation
select case (char (parse_node_get_rule_key (pn_var)))
case ("results")
case default
call msg_fatal ("export: object (type) '" &
// char (parse_node_get_rule_key (pn_var)) &
// "' not supported yet")
end select
pn_var => parse_node_get_next_ptr (pn_var)
end do
else
allocate (cmd%name (0))
end if
end subroutine cmd_export_compile
@ %def cmd_export_compile
@ Execute. Scan the list of objects to export.
<<Commands: cmd export: TBP>>=
procedure :: execute => cmd_export_execute
<<Commands: sub interfaces>>=
module subroutine cmd_export_execute (cmd, global)
class(cmd_export_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_export_execute
<<Commands: procedures>>=
module subroutine cmd_export_execute (cmd, global)
class(cmd_export_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
call global%append_exports (cmd%name)
end subroutine cmd_export_execute
@ %def cmd_export_execute
@
\subsubsection{Quit command execution}
The code is the return code of the whole program if it is terminated
by this command.
<<Commands: types>>=
type, extends (command_t) :: cmd_quit_t
private
logical :: has_code = .false.
type(parse_node_t), pointer :: pn_code_expr => null ()
contains
<<Commands: cmd quit: TBP>>
end type cmd_quit_t
@ %def cmd_quit_t
@ Output.
<<Commands: cmd quit: TBP>>=
procedure :: write => cmd_quit_write
<<Commands: sub interfaces>>=
module subroutine cmd_quit_write (cmd, unit, indent)
class(cmd_quit_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
end subroutine cmd_quit_write
<<Commands: procedures>>=
module subroutine cmd_quit_write (cmd, unit, indent)
class(cmd_quit_t), intent(in) :: cmd
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write (u, "(1x,A,L1)") "quit: has_code = ", cmd%has_code
end subroutine cmd_quit_write
@ %def cmd_quit_write
@ Compile: allocate a [[quit]] object which serves as a placeholder.
<<Commands: cmd quit: TBP>>=
procedure :: compile => cmd_quit_compile
<<Commands: sub interfaces>>=
module subroutine cmd_quit_compile (cmd, global)
class(cmd_quit_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_quit_compile
<<Commands: procedures>>=
module subroutine cmd_quit_compile (cmd, global)
class(cmd_quit_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_arg
pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
if (associated (pn_arg)) then
cmd%pn_code_expr => parse_node_get_sub_ptr (pn_arg)
cmd%has_code = .true.
end if
end subroutine cmd_quit_compile
@ %def cmd_quit_compile
@ Execute: The quit command does not execute anything, it just stops
command execution. This is achieved by setting quit flag and quit
code in the global variable list. However, the return code, if
present, is an expression which has to be evaluated.
<<Commands: cmd quit: TBP>>=
procedure :: execute => cmd_quit_execute
<<Commands: sub interfaces>>=
module subroutine cmd_quit_execute (cmd, global)
class(cmd_quit_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
end subroutine cmd_quit_execute
<<Commands: procedures>>=
module subroutine cmd_quit_execute (cmd, global)
class(cmd_quit_t), intent(inout) :: cmd
type(rt_data_t), intent(inout), target :: global
type(var_list_t), pointer :: var_list
logical :: is_known
var_list => global%get_var_list_ptr ()
if (cmd%has_code) then
global%quit_code = eval_int (cmd%pn_code_expr, var_list, &
is_known=is_known)
if (.not. is_known) then
call msg_error ("Undefined return code of quit/exit command")
end if
end if
global%quit = .true.
end subroutine cmd_quit_execute
@ %def cmd_quit_execute
@
\subsection{The command list}
The command list holds a list of commands and relevant global data.
<<Commands: public>>=
public :: command_list_t
<<Commands: types>>=
type :: command_list_t
! not private anymore as required by the whizard-c-interface
class(command_t), pointer :: first => null ()
class(command_t), pointer :: last => null ()
contains
<<Commands: command list: TBP>>
end type command_list_t
@ %def command_list_t
@ Output.
<<Commands: command list: TBP>>=
procedure :: write => command_list_write
<<Commands: sub interfaces>>=
recursive module subroutine command_list_write (cmd_list, unit, indent)
class(command_list_t), intent(in) :: cmd_list
integer, intent(in), optional :: unit, indent
end subroutine command_list_write
<<Commands: procedures>>=
recursive module subroutine command_list_write (cmd_list, unit, indent)
class(command_list_t), intent(in) :: cmd_list
integer, intent(in), optional :: unit, indent
class(command_t), pointer :: cmd
cmd => cmd_list%first
do while (associated (cmd))
call cmd%write (unit, indent)
cmd => cmd%next
end do
end subroutine command_list_write
@ %def command_list_write
@ Append a new command to the list and free the original pointer.
<<Commands: command list: TBP>>=
procedure :: append => command_list_append
<<Commands: sub interfaces>>=
module subroutine command_list_append (cmd_list, command)
class(command_list_t), intent(inout) :: cmd_list
class(command_t), intent(inout), pointer :: command
end subroutine command_list_append
<<Commands: procedures>>=
module subroutine command_list_append (cmd_list, command)
class(command_list_t), intent(inout) :: cmd_list
class(command_t), intent(inout), pointer :: command
if (associated (cmd_list%last)) then
cmd_list%last%next => command
else
cmd_list%first => command
end if
cmd_list%last => command
command => null ()
end subroutine command_list_append
@ %def command_list_append
@ Finalize.
<<Commands: command list: TBP>>=
procedure :: final => command_list_final
<<Commands: sub interfaces>>=
recursive module subroutine command_list_final (cmd_list)
class(command_list_t), intent(inout) :: cmd_list
end subroutine command_list_final
<<Commands: procedures>>=
recursive module subroutine command_list_final (cmd_list)
class(command_list_t), intent(inout) :: cmd_list
class(command_t), pointer :: command
do while (associated (cmd_list%first))
command => cmd_list%first
cmd_list%first => cmd_list%first%next
call command%final ()
deallocate (command)
end do
cmd_list%last => null ()
end subroutine command_list_final
@ %def command_list_final
@
\subsection{Compiling the parse tree}
Transform a parse tree into a command list. Initialization is assumed
to be done.
After each command, we set a breakpoint.
Gfortran 7/8/9 bug: has to remain in the main module:
<<Commands: command list: TBP>>=
procedure :: compile => command_list_compile
<<Commands: main procedures>>=
recursive subroutine command_list_compile (cmd_list, pn, global)
class(command_list_t), intent(inout), target :: cmd_list
type(parse_node_t), intent(in), target :: pn
type(rt_data_t), intent(inout), target :: global
type(parse_node_t), pointer :: pn_cmd
class(command_t), pointer :: command
integer :: i
pn_cmd => parse_node_get_sub_ptr (pn)
do i = 1, parse_node_get_n_sub (pn)
call dispatch_command (command, pn_cmd)
call command%compile (global)
call cmd_list%append (command)
call terminate_now_if_signal ()
pn_cmd => parse_node_get_next_ptr (pn_cmd)
end do
end subroutine command_list_compile
@ %def command_list_compile
@
\subsection{Executing the command list}
Before executing a command we should execute its options (if any). After
that, reset the options, i.e., remove temporary effects from the global
state.
Also here, after each command we set a breakpoint.
<<Commands: command list: TBP>>=
procedure :: execute => command_list_execute
<<Commands: sub interfaces>>=
recursive module subroutine command_list_execute (cmd_list, global)
class(command_list_t), intent(in) :: cmd_list
type(rt_data_t), intent(inout), target :: global
end subroutine command_list_execute
<<Commands: procedures>>=
recursive module subroutine command_list_execute (cmd_list, global)
class(command_list_t), intent(in) :: cmd_list
type(rt_data_t), intent(inout), target :: global
class(command_t), pointer :: command
command => cmd_list%first
COMMAND_COND: do while (associated (command))
call command%execute_options (global)
call command%execute (global)
call command%reset_options (global)
call terminate_now_if_signal ()
if (global%quit) exit COMMAND_COND
command => command%next
end do COMMAND_COND
end subroutine command_list_execute
@ %def command_list_execute
@
\subsection{Command list syntax}
<<Commands: public>>=
public :: syntax_cmd_list
<<Commands: variables>>=
type(syntax_t), target, save :: syntax_cmd_list
@ %def syntax_cmd_list
<<Commands: public>>=
public :: syntax_cmd_list_init
<<Commands: sub interfaces>>=
module subroutine syntax_cmd_list_init ()
end subroutine syntax_cmd_list_init
<<Commands: procedures>>=
module subroutine syntax_cmd_list_init ()
type(ifile_t) :: ifile
call define_cmd_list_syntax (ifile)
call syntax_init (syntax_cmd_list, ifile)
call ifile_final (ifile)
end subroutine syntax_cmd_list_init
@ %def syntax_cmd_list_init
<<Commands: public>>=
public :: syntax_cmd_list_final
<<Commands: sub interfaces>>=
module subroutine syntax_cmd_list_final ()
end subroutine syntax_cmd_list_final
<<Commands: procedures>>=
module subroutine syntax_cmd_list_final ()
call syntax_final (syntax_cmd_list)
end subroutine syntax_cmd_list_final
@ %def syntax_cmd_list_final
<<Commands: public>>=
public :: syntax_cmd_list_write
<<Commands: sub interfaces>>=
module subroutine syntax_cmd_list_write (unit)
integer, intent(in), optional :: unit
end subroutine syntax_cmd_list_write
<<Commands: procedures>>=
module subroutine syntax_cmd_list_write (unit)
integer, intent(in), optional :: unit
call syntax_write (syntax_cmd_list, unit)
end subroutine syntax_cmd_list_write
@ %def syntax_cmd_list_write
<<Commands: procedures>>=
subroutine define_cmd_list_syntax (ifile)
type(ifile_t), intent(inout) :: ifile
call ifile_append (ifile, "SEQ command_list = command*")
call ifile_append (ifile, "ALT command = " &
// "cmd_model | cmd_library | cmd_iterations | cmd_sample_format | " &
// "cmd_var | cmd_slha | " &
// "cmd_show | cmd_clear | " &
// "cmd_expect | " &
// "cmd_cuts | cmd_scale | cmd_fac_scale | cmd_ren_scale | " &
// "cmd_weight | cmd_selection | cmd_reweight | " &
// "cmd_beams | cmd_beams_pol_density | cmd_beams_pol_fraction | " &
// "cmd_beams_momentum | cmd_beams_theta | cmd_beams_phi | " &
// "cmd_integrate | " &
// "cmd_observable | cmd_histogram | cmd_plot | cmd_graph | " &
// "cmd_record | " &
// "cmd_analysis | cmd_alt_setup | " &
// "cmd_unstable | cmd_stable | cmd_simulate | cmd_rescan | " &
// "cmd_process | cmd_compile | cmd_exec | " &
// "cmd_scan | cmd_if | cmd_include | cmd_quit | " &
// "cmd_export | " &
// "cmd_polarized | cmd_unpolarized | " &
// "cmd_open_out | cmd_close_out | cmd_printf | " &
// "cmd_write_analysis | cmd_compile_analysis | cmd_nlo | cmd_components")
call ifile_append (ifile, "GRO options = '{' local_command_list '}'")
call ifile_append (ifile, "SEQ local_command_list = local_command*")
call ifile_append (ifile, "ALT local_command = " &
// "cmd_model | cmd_library | cmd_iterations | cmd_sample_format | " &
// "cmd_var | cmd_slha | " &
// "cmd_show | " &
// "cmd_expect | " &
// "cmd_cuts | cmd_scale | cmd_fac_scale | cmd_ren_scale | " &
// "cmd_weight | cmd_selection | cmd_reweight | " &
// "cmd_beams | cmd_beams_pol_density | cmd_beams_pol_fraction | " &
// "cmd_beams_momentum | cmd_beams_theta | cmd_beams_phi | " &
// "cmd_observable | cmd_histogram | cmd_plot | cmd_graph | " &
// "cmd_clear | cmd_record | " &
// "cmd_analysis | cmd_alt_setup | " &
// "cmd_open_out | cmd_close_out | cmd_printf | " &
// "cmd_write_analysis | cmd_compile_analysis | cmd_nlo | cmd_components")
call ifile_append (ifile, "SEQ cmd_model = model '=' model_name model_arg?")
call ifile_append (ifile, "KEY model")
call ifile_append (ifile, "ALT model_name = model_id | string_literal")
call ifile_append (ifile, "IDE model_id")
call ifile_append (ifile, "ARG model_arg = ( model_scheme? )")
call ifile_append (ifile, "ALT model_scheme = " &
// "ufo_spec | scheme_id | string_literal")
call ifile_append (ifile, "SEQ ufo_spec = ufo ufo_arg?")
call ifile_append (ifile, "KEY ufo")
call ifile_append (ifile, "ARG ufo_arg = ( string_literal )")
call ifile_append (ifile, "IDE scheme_id")
call ifile_append (ifile, "SEQ cmd_library = library '=' lib_name")
call ifile_append (ifile, "KEY library")
call ifile_append (ifile, "ALT lib_name = lib_id | string_literal")
call ifile_append (ifile, "IDE lib_id")
call ifile_append (ifile, "ALT cmd_var = " &
// "cmd_log_decl | cmd_log | " &
// "cmd_int | cmd_real | cmd_complex | cmd_num | " &
// "cmd_string_decl | cmd_string | cmd_alias | " &
// "cmd_result")
call ifile_append (ifile, "SEQ cmd_log_decl = logical cmd_log")
call ifile_append (ifile, "SEQ cmd_log = '?' var_name '=' lexpr")
call ifile_append (ifile, "SEQ cmd_int = int var_name '=' expr")
call ifile_append (ifile, "SEQ cmd_real = real var_name '=' expr")
call ifile_append (ifile, "SEQ cmd_complex = complex var_name '=' expr")
call ifile_append (ifile, "SEQ cmd_num = var_name '=' expr")
call ifile_append (ifile, "SEQ cmd_string_decl = string cmd_string")
call ifile_append (ifile, "SEQ cmd_string = " &
// "'$' var_name '=' sexpr") ! $
call ifile_append (ifile, "SEQ cmd_alias = alias var_name '=' cexpr")
call ifile_append (ifile, "SEQ cmd_result = result '=' expr")
call ifile_append (ifile, "SEQ cmd_slha = slha_action slha_arg options?")
call ifile_append (ifile, "ALT slha_action = " &
// "read_slha | write_slha")
call ifile_append (ifile, "KEY read_slha")
call ifile_append (ifile, "KEY write_slha")
call ifile_append (ifile, "ARG slha_arg = ( string_literal )")
call ifile_append (ifile, "SEQ cmd_show = show show_arg options?")
call ifile_append (ifile, "KEY show")
call ifile_append (ifile, "ARG show_arg = ( showable* )")
call ifile_append (ifile, "ALT showable = " &
// "model | library | beams | iterations | " &
// "cuts | weight | logical | string | pdg | " &
// "scale | factorization_scale | renormalization_scale | " &
// "selection | reweight | analysis | " &
// "stable | unstable | polarized | unpolarized | " &
// "expect | intrinsic | int | real | complex | " &
// "alias_var | string | results | result_var | " &
// "log_var | string_var | var_name")
call ifile_append (ifile, "KEY results")
call ifile_append (ifile, "KEY intrinsic")
call ifile_append (ifile, "SEQ alias_var = alias var_name")
call ifile_append (ifile, "SEQ result_var = result_key result_arg?")
call ifile_append (ifile, "SEQ log_var = '?' var_name")
call ifile_append (ifile, "SEQ string_var = '$' var_name") ! $
call ifile_append (ifile, "SEQ cmd_clear = clear clear_arg options?")
call ifile_append (ifile, "KEY clear")
call ifile_append (ifile, "ARG clear_arg = ( clearable* )")
call ifile_append (ifile, "ALT clearable = " &
// "beams | iterations | " &
// "cuts | weight | " &
// "scale | factorization_scale | renormalization_scale | " &
// "selection | reweight | analysis | " &
// "unstable | polarized | " &
// "expect | " &
// "log_var | string_var | var_name")
call ifile_append (ifile, "SEQ cmd_expect = expect expect_arg options?")
call ifile_append (ifile, "KEY expect")
call ifile_append (ifile, "ARG expect_arg = ( lexpr )")
call ifile_append (ifile, "SEQ cmd_cuts = cuts '=' lexpr")
call ifile_append (ifile, "SEQ cmd_scale = scale '=' expr")
call ifile_append (ifile, "SEQ cmd_fac_scale = " &
// "factorization_scale '=' expr")
call ifile_append (ifile, "SEQ cmd_ren_scale = " &
// "renormalization_scale '=' expr")
call ifile_append (ifile, "SEQ cmd_weight = weight '=' expr")
call ifile_append (ifile, "SEQ cmd_selection = selection '=' lexpr")
call ifile_append (ifile, "SEQ cmd_reweight = reweight '=' expr")
call ifile_append (ifile, "KEY cuts")
call ifile_append (ifile, "KEY scale")
call ifile_append (ifile, "KEY factorization_scale")
call ifile_append (ifile, "KEY renormalization_scale")
call ifile_append (ifile, "KEY weight")
call ifile_append (ifile, "KEY selection")
call ifile_append (ifile, "KEY reweight")
call ifile_append (ifile, "SEQ cmd_process = process process_id '=' " &
// "process_prt '=>' prt_state_list options?")
call ifile_append (ifile, "KEY process")
call ifile_append (ifile, "KEY '=>'")
call ifile_append (ifile, "LIS process_prt = cexpr+")
call ifile_append (ifile, "LIS prt_state_list = prt_state_sum+")
call ifile_append (ifile, "SEQ prt_state_sum = " &
// "prt_state prt_state_addition*")
call ifile_append (ifile, "SEQ prt_state_addition = '+' prt_state")
call ifile_append (ifile, "ALT prt_state = grouped_prt_state_list | cexpr")
call ifile_append (ifile, "GRO grouped_prt_state_list = " &
// "( prt_state_list )")
call ifile_append (ifile, "SEQ cmd_compile = compile_cmd options?")
call ifile_append (ifile, "SEQ compile_cmd = compile_clause compile_arg?")
call ifile_append (ifile, "SEQ compile_clause = compile exec_name_spec?")
call ifile_append (ifile, "KEY compile")
call ifile_append (ifile, "SEQ exec_name_spec = as exec_name")
call ifile_append (ifile, "KEY as")
call ifile_append (ifile, "ALT exec_name = exec_id | string_literal")
call ifile_append (ifile, "IDE exec_id")
call ifile_append (ifile, "ARG compile_arg = ( lib_name* )")
call ifile_append (ifile, "SEQ cmd_exec = exec exec_arg")
call ifile_append (ifile, "KEY exec")
call ifile_append (ifile, "ARG exec_arg = ( sexpr )")
call ifile_append (ifile, "SEQ cmd_beams = beams '=' beam_def")
call ifile_append (ifile, "KEY beams")
call ifile_append (ifile, "SEQ beam_def = beam_spec strfun_seq*")
call ifile_append (ifile, "SEQ beam_spec = beam_list")
call ifile_append (ifile, "LIS beam_list = cexpr, cexpr?")
call ifile_append (ifile, "SEQ cmd_beams_pol_density = " &
// "beams_pol_density '=' beams_pol_spec")
call ifile_append (ifile, "KEY beams_pol_density")
call ifile_append (ifile, "LIS beams_pol_spec = smatrix, smatrix?")
call ifile_append (ifile, "SEQ smatrix = '@' smatrix_arg")
! call ifile_append (ifile, "KEY '@'") !!! Key already exists
call ifile_append (ifile, "ARG smatrix_arg = ( sentry* )")
call ifile_append (ifile, "SEQ sentry = expr extra_sentry*")
call ifile_append (ifile, "SEQ extra_sentry = ':' expr")
call ifile_append (ifile, "SEQ cmd_beams_pol_fraction = " &
// "beams_pol_fraction '=' beams_par_spec")
call ifile_append (ifile, "KEY beams_pol_fraction")
call ifile_append (ifile, "SEQ cmd_beams_momentum = " &
// "beams_momentum '=' beams_par_spec")
call ifile_append (ifile, "KEY beams_momentum")
call ifile_append (ifile, "SEQ cmd_beams_theta = " &
// "beams_theta '=' beams_par_spec")
call ifile_append (ifile, "KEY beams_theta")
call ifile_append (ifile, "SEQ cmd_beams_phi = " &
// "beams_phi '=' beams_par_spec")
call ifile_append (ifile, "KEY beams_phi")
call ifile_append (ifile, "LIS beams_par_spec = expr, expr?")
call ifile_append (ifile, "SEQ strfun_seq = '=>' strfun_pair")
call ifile_append (ifile, "LIS strfun_pair = strfun_def, strfun_def?")
call ifile_append (ifile, "SEQ strfun_def = strfun_id")
call ifile_append (ifile, "ALT strfun_id = " &
// "none | lhapdf | lhapdf_photon | pdf_builtin | pdf_builtin_photon | " &
// "isr | epa | ewa | circe1 | circe2 | energy_scan | " &
// "gaussian | beam_events")
call ifile_append (ifile, "KEY none")
call ifile_append (ifile, "KEY lhapdf")
call ifile_append (ifile, "KEY lhapdf_photon")
call ifile_append (ifile, "KEY pdf_builtin")
call ifile_append (ifile, "KEY pdf_builtin_photon")
call ifile_append (ifile, "KEY isr")
call ifile_append (ifile, "KEY epa")
call ifile_append (ifile, "KEY ewa")
call ifile_append (ifile, "KEY circe1")
call ifile_append (ifile, "KEY circe2")
call ifile_append (ifile, "KEY energy_scan")
call ifile_append (ifile, "KEY gaussian")
call ifile_append (ifile, "KEY beam_events")
call ifile_append (ifile, "SEQ cmd_integrate = " &
// "integrate proc_arg options?")
call ifile_append (ifile, "KEY integrate")
call ifile_append (ifile, "ARG proc_arg = ( proc_id* )")
call ifile_append (ifile, "IDE proc_id")
call ifile_append (ifile, "SEQ cmd_iterations = " &
// "iterations '=' iterations_list")
call ifile_append (ifile, "KEY iterations")
call ifile_append (ifile, "LIS iterations_list = iterations_spec+")
call ifile_append (ifile, "ALT iterations_spec = it_spec")
call ifile_append (ifile, "SEQ it_spec = expr calls_spec adapt_spec?")
call ifile_append (ifile, "SEQ calls_spec = ':' expr")
call ifile_append (ifile, "SEQ adapt_spec = ':' sexpr")
call ifile_append (ifile, "SEQ cmd_components = " &
// "active '=' component_list")
call ifile_append (ifile, "KEY active")
call ifile_append (ifile, "LIS component_list = sexpr+")
call ifile_append (ifile, "SEQ cmd_sample_format = " &
// "sample_format '=' event_format_list")
call ifile_append (ifile, "KEY sample_format")
call ifile_append (ifile, "LIS event_format_list = event_format+")
call ifile_append (ifile, "IDE event_format")
call ifile_append (ifile, "SEQ cmd_observable = " &
// "observable analysis_tag options?")
call ifile_append (ifile, "KEY observable")
call ifile_append (ifile, "SEQ cmd_histogram = " &
// "histogram analysis_tag histogram_arg " &
// "options?")
call ifile_append (ifile, "KEY histogram")
call ifile_append (ifile, "ARG histogram_arg = (expr, expr, expr?)")
call ifile_append (ifile, "SEQ cmd_plot = plot analysis_tag options?")
call ifile_append (ifile, "KEY plot")
call ifile_append (ifile, "SEQ cmd_graph = graph graph_term '=' graph_def")
call ifile_append (ifile, "KEY graph")
call ifile_append (ifile, "SEQ graph_term = analysis_tag options?")
call ifile_append (ifile, "SEQ graph_def = graph_term graph_append*")
call ifile_append (ifile, "SEQ graph_append = '&' graph_term")
call ifile_append (ifile, "SEQ cmd_analysis = analysis '=' lexpr")
call ifile_append (ifile, "KEY analysis")
call ifile_append (ifile, "SEQ cmd_alt_setup = " &
// "alt_setup '=' option_list_expr")
call ifile_append (ifile, "KEY alt_setup")
call ifile_append (ifile, "ALT option_list_expr = " &
// "grouped_option_list | option_list")
call ifile_append (ifile, "GRO grouped_option_list = ( option_list_expr )")
call ifile_append (ifile, "LIS option_list = options+")
call ifile_append (ifile, "SEQ cmd_open_out = open_out open_arg options?")
call ifile_append (ifile, "SEQ cmd_close_out = close_out open_arg options?")
call ifile_append (ifile, "KEY open_out")
call ifile_append (ifile, "KEY close_out")
call ifile_append (ifile, "ARG open_arg = (sexpr)")
call ifile_append (ifile, "SEQ cmd_printf = printf_cmd options?")
call ifile_append (ifile, "SEQ printf_cmd = printf_clause sprintf_args?")
call ifile_append (ifile, "SEQ printf_clause = printf sexpr")
call ifile_append (ifile, "KEY printf")
call ifile_append (ifile, "SEQ cmd_record = record_cmd")
call ifile_append (ifile, "SEQ cmd_unstable = " &
// "unstable cexpr unstable_arg options?")
call ifile_append (ifile, "KEY unstable")
call ifile_append (ifile, "ARG unstable_arg = ( proc_id* )")
call ifile_append (ifile, "SEQ cmd_stable = stable stable_list options?")
call ifile_append (ifile, "KEY stable")
call ifile_append (ifile, "LIS stable_list = cexpr+")
call ifile_append (ifile, "KEY polarized")
call ifile_append (ifile, "SEQ cmd_polarized = polarized polarized_list options?")
call ifile_append (ifile, "LIS polarized_list = cexpr+")
call ifile_append (ifile, "KEY unpolarized")
call ifile_append (ifile, "SEQ cmd_unpolarized = unpolarized unpolarized_list options?")
call ifile_append (ifile, "LIS unpolarized_list = cexpr+")
call ifile_append (ifile, "SEQ cmd_simulate = " &
// "simulate proc_arg options?")
call ifile_append (ifile, "KEY simulate")
call ifile_append (ifile, "SEQ cmd_rescan = " &
// "rescan sexpr proc_arg options?")
call ifile_append (ifile, "KEY rescan")
call ifile_append (ifile, "SEQ cmd_scan = scan scan_var scan_body?")
call ifile_append (ifile, "KEY scan")
call ifile_append (ifile, "ALT scan_var = " &
// "scan_log_decl | scan_log | " &
// "scan_int | scan_real | scan_complex | scan_num | " &
// "scan_string_decl | scan_string | scan_alias | " &
// "scan_cuts | scan_weight | " &
// "scan_scale | scan_ren_scale | scan_fac_scale | " &
// "scan_selection | scan_reweight | scan_analysis | " &
// "scan_model | scan_library")
call ifile_append (ifile, "SEQ scan_log_decl = logical scan_log")
call ifile_append (ifile, "SEQ scan_log = '?' var_name '=' scan_log_arg")
call ifile_append (ifile, "ARG scan_log_arg = ( lexpr* )")
call ifile_append (ifile, "SEQ scan_int = int var_name '=' scan_num_arg")
call ifile_append (ifile, "SEQ scan_real = real var_name '=' scan_num_arg")
call ifile_append (ifile, "SEQ scan_complex = " &
// "complex var_name '=' scan_num_arg")
call ifile_append (ifile, "SEQ scan_num = var_name '=' scan_num_arg")
call ifile_append (ifile, "ARG scan_num_arg = ( range* )")
call ifile_append (ifile, "ALT range = grouped_range | range_expr")
call ifile_append (ifile, "GRO grouped_range = ( range_expr )")
call ifile_append (ifile, "SEQ range_expr = expr range_spec?")
call ifile_append (ifile, "SEQ range_spec = '=>' expr step_spec?")
call ifile_append (ifile, "SEQ step_spec = step_op expr")
call ifile_append (ifile, "ALT step_op = " &
// "'/+' | '/-' | '/*' | '//' | '/+/' | '/*/'")
call ifile_append (ifile, "KEY '/+'")
call ifile_append (ifile, "KEY '/-'")
call ifile_append (ifile, "KEY '/*'")
call ifile_append (ifile, "KEY '//'")
call ifile_append (ifile, "KEY '/+/'")
call ifile_append (ifile, "KEY '/*/'")
call ifile_append (ifile, "SEQ scan_string_decl = string scan_string")
call ifile_append (ifile, "SEQ scan_string = " &
// "'$' var_name '=' scan_string_arg")
call ifile_append (ifile, "ARG scan_string_arg = ( sexpr* )")
call ifile_append (ifile, "SEQ scan_alias = " &
// "alias var_name '=' scan_alias_arg")
call ifile_append (ifile, "ARG scan_alias_arg = ( cexpr* )")
call ifile_append (ifile, "SEQ scan_cuts = cuts '=' scan_lexpr_arg")
call ifile_append (ifile, "ARG scan_lexpr_arg = ( lexpr* )")
call ifile_append (ifile, "SEQ scan_scale = scale '=' scan_expr_arg")
call ifile_append (ifile, "ARG scan_expr_arg = ( expr* )")
call ifile_append (ifile, "SEQ scan_fac_scale = " &
// "factorization_scale '=' scan_expr_arg")
call ifile_append (ifile, "SEQ scan_ren_scale = " &
// "renormalization_scale '=' scan_expr_arg")
call ifile_append (ifile, "SEQ scan_weight = weight '=' scan_expr_arg")
call ifile_append (ifile, "SEQ scan_selection = selection '=' scan_lexpr_arg")
call ifile_append (ifile, "SEQ scan_reweight = reweight '=' scan_expr_arg")
call ifile_append (ifile, "SEQ scan_analysis = analysis '=' scan_lexpr_arg")
call ifile_append (ifile, "SEQ scan_model = model '=' scan_model_arg")
call ifile_append (ifile, "ARG scan_model_arg = ( model_name* )")
call ifile_append (ifile, "SEQ scan_library = library '=' scan_library_arg")
call ifile_append (ifile, "ARG scan_library_arg = ( lib_name* )")
call ifile_append (ifile, "GRO scan_body = '{' command_list '}'")
call ifile_append (ifile, "SEQ cmd_if = " &
// "if lexpr then command_list elsif_clauses else_clause endif")
call ifile_append (ifile, "SEQ elsif_clauses = cmd_elsif*")
call ifile_append (ifile, "SEQ cmd_elsif = elsif lexpr then command_list")
call ifile_append (ifile, "SEQ else_clause = cmd_else?")
call ifile_append (ifile, "SEQ cmd_else = else command_list")
call ifile_append (ifile, "SEQ cmd_include = include include_arg")
call ifile_append (ifile, "KEY include")
call ifile_append (ifile, "ARG include_arg = ( string_literal )")
call ifile_append (ifile, "SEQ cmd_quit = quit_cmd quit_arg?")
call ifile_append (ifile, "ALT quit_cmd = quit | exit")
call ifile_append (ifile, "KEY quit")
call ifile_append (ifile, "KEY exit")
call ifile_append (ifile, "ARG quit_arg = ( expr )")
call ifile_append (ifile, "SEQ cmd_export = export show_arg options?")
call ifile_append (ifile, "KEY export")
call ifile_append (ifile, "SEQ cmd_write_analysis = " &
// "write_analysis_clause options?")
call ifile_append (ifile, "SEQ cmd_compile_analysis = " &
// "compile_analysis_clause options?")
call ifile_append (ifile, "SEQ write_analysis_clause = " &
// "write_analysis write_analysis_arg?")
call ifile_append (ifile, "SEQ compile_analysis_clause = " &
// "compile_analysis write_analysis_arg?")
call ifile_append (ifile, "KEY write_analysis")
call ifile_append (ifile, "KEY compile_analysis")
call ifile_append (ifile, "ARG write_analysis_arg = ( analysis_tag* )")
call ifile_append (ifile, "SEQ cmd_nlo = " &
// "nlo_calculation '=' nlo_calculation_list")
call ifile_append (ifile, "KEY nlo_calculation")
call ifile_append (ifile, "LIS nlo_calculation_list = nlo_comp+")
call ifile_append (ifile, "ALT nlo_comp = " // &
"full | born | real | virtual | dglap | subtraction | " // &
"mismatch | GKS")
call ifile_append (ifile, "KEY full")
call ifile_append (ifile, "KEY born")
call ifile_append (ifile, "KEY virtual")
call ifile_append (ifile, "KEY dglap")
call ifile_append (ifile, "KEY subtraction")
call ifile_append (ifile, "KEY mismatch")
call ifile_append (ifile, "KEY GKS")
call define_expr_syntax (ifile, particles=.true., analysis=.true.)
end subroutine define_cmd_list_syntax
@ %def define_cmd_list_syntax
<<Commands: public>>=
public :: lexer_init_cmd_list
<<Commands: sub interfaces>>=
module subroutine lexer_init_cmd_list (lexer, parent_lexer)
type(lexer_t), intent(out) :: lexer
type(lexer_t), intent(in), optional, target :: parent_lexer
end subroutine lexer_init_cmd_list
<<Commands: procedures>>=
module subroutine lexer_init_cmd_list (lexer, parent_lexer)
type(lexer_t), intent(out) :: lexer
type(lexer_t), intent(in), optional, target :: parent_lexer
call lexer_init (lexer, &
comment_chars = "#!", &
quote_chars = '"', &
quote_match = '"', &
single_chars = "()[]{},;:&%?$@", &
special_class = [ "+-*/^", "<>=~ " ] , &
keyword_list = syntax_get_keyword_list_ptr (syntax_cmd_list), &
parent = parent_lexer)
end subroutine lexer_init_cmd_list
@ %def lexer_init_cmd_list
@
\subsection{Unit Tests}
Test module, followed by the corresponding implementation module.
<<[[commands_ut.f90]]>>=
<<File header>>
module commands_ut
use unit_tests
use system_dependencies, only: MPOST_AVAILABLE
use commands_uti
<<Standard module head>>
<<Commands: public test>>
contains
<<Commands: test driver>>
end module commands_ut
@ %def commands_ut
@
<<[[commands_uti.f90]]>>=
<<File header>>
module commands_uti
<<Use kinds>>
use kinds, only: i64
<<Use strings>>
use io_units
use ifiles
use parser
use interactions, only: reset_interaction_counter
use prclib_stacks
use analysis
use variables, only: var_list_t
use models
use slha_interface
use rt_data
use event_base, only: generic_event_t, event_callback_t
use commands
<<Standard module head>>
<<Commands: test declarations>>
<<Commands: test auxiliary types>>
contains
<<Commands: tests>>
<<Commands: test auxiliary>>
end module commands_uti
@ %def commands_uti
@ API: driver for the unit tests below.
<<Commands: public test>>=
public :: commands_test
<<Commands: test driver>>=
subroutine commands_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Commands: execute tests>>
end subroutine commands_test
@ %def commands_test
@
\subsubsection{Prepare Sindarin code}
This routine parses an internal file, prints the parse tree, and
returns a parse node to the root. We use the routine in the tests
below.
<<Commands: public test auxiliary>>=
public :: parse_ifile
<<Commands: test auxiliary>>=
subroutine parse_ifile (ifile, pn_root, u)
use ifiles
use lexers
use parser
use commands
type(ifile_t), intent(in) :: ifile
type(parse_node_t), pointer, intent(out) :: pn_root
integer, intent(in), optional :: u
type(stream_t), target :: stream
type(lexer_t), target :: lexer
type(parse_tree_t) :: parse_tree
call lexer_init_cmd_list (lexer)
call stream_init (stream, ifile)
call lexer_assign_stream (lexer, stream)
call parse_tree_init (parse_tree, syntax_cmd_list, lexer)
if (present (u)) call parse_tree_write (parse_tree, u)
pn_root => parse_tree%get_root_ptr ()
call stream_final (stream)
call lexer_final (lexer)
end subroutine parse_ifile
@ %def parse_ifile
@
\subsubsection{Empty command list}
Compile and execute an empty command list. Should do nothing but
test the integrity of the workflow.
<<Commands: execute tests>>=
call test (commands_1, "commands_1", &
"empty command list", &
u, results)
<<Commands: test declarations>>=
public :: commands_1
<<Commands: tests>>=
subroutine commands_1 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_1"
write (u, "(A)") "* Purpose: compile and execute empty command list"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Parse empty file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
if (associated (pn_root)) then
call command_list%compile (pn_root, global)
end if
write (u, "(A)")
write (u, "(A)") "* Execute command list"
call global%activate ()
call command_list%execute (global)
call global%deactivate ()
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call syntax_cmd_list_final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_1"
end subroutine commands_1
@ %def commands_1
@
\subsubsection{Read model}
Execute a [[model]] assignment.
<<Commands: execute tests>>=
call test (commands_2, "commands_2", &
"model", &
u, results)
<<Commands: test declarations>>=
public :: commands_2
<<Commands: tests>>=
subroutine commands_2 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_2"
write (u, "(A)") "* Purpose: set model"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = "Test"')
call ifile_write (ifile, u)
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_2"
end subroutine commands_2
@ %def commands_2
@
\subsubsection{Declare Process}
Read a model, then declare a process. The process library is allocated
explicitly. For the process definition, We take the default ([[omega]])
method. Since we do not compile, \oMega\ is not actually called.
<<Commands: execute tests>>=
call test (commands_3, "commands_3", &
"process declaration", &
u, results)
<<Commands: test declarations>>=
public :: commands_3
<<Commands: tests>>=
subroutine commands_3 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
type(prclib_entry_t), pointer :: lib
write (u, "(A)") "* Test output: commands_3"
write (u, "(A)") "* Purpose: define process"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call global%global_init ()
call global%var_list%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
allocate (lib)
call lib%init (var_str ("lib_cmd3"))
call global%add_prclib (lib)
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = "Test"')
call ifile_append (ifile, 'process t3 = s, s => s, s')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%prclib_stack%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_3"
end subroutine commands_3
@ %def commands_3
@
\subsubsection{Compile Process}
Read a model, then declare a process and compile the library. The process
library is allocated explicitly. For the process definition, We take the
default ([[unit_test]]) method. There is no external code, so compilation of
the library is merely a formal status change.
<<Commands: execute tests>>=
call test (commands_4, "commands_4", &
"compilation", &
u, results)
<<Commands: test declarations>>=
public :: commands_4
<<Commands: tests>>=
subroutine commands_4 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
type(prclib_entry_t), pointer :: lib
write (u, "(A)") "* Test output: commands_4"
write (u, "(A)") "* Purpose: define process and compile library"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call global%global_init ()
call global%var_list%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known=.true.)
allocate (lib)
call lib%init (var_str ("lib_cmd4"))
call global%add_prclib (lib)
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = "Test"')
call ifile_append (ifile, 'process t4 = s, s => s, s')
call ifile_append (ifile, 'compile ("lib_cmd4")')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%prclib_stack%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_4"
end subroutine commands_4
@ %def commands_4
@
\subsubsection{Integrate Process}
Read a model, then declare a process, compile the library, and
integrate over phase space. We take the
default ([[unit_test]]) method and use the simplest methods of
phase-space parameterization and integration.
<<Commands: execute tests>>=
call test (commands_5, "commands_5", &
"integration", &
u, results)
<<Commands: test declarations>>=
public :: commands_5
<<Commands: tests>>=
subroutine commands_5 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
type(prclib_entry_t), pointer :: lib
write (u, "(A)") "* Test output: commands_5"
write (u, "(A)") "* Purpose: define process, iterations, and integrate"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call global%global_init ()
call global%var_list%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known=.true.)
call global%var_list%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known=.true.)
call global%var_list%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known=.true.)
call global%var_list%set_log (var_str ("?vis_history"),&
.false., is_known=.true.)
call global%var_list%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%var_list%set_real (var_str ("sqrts"), &
1000._default, is_known=.true.)
call global%var_list%set_int (var_str ("seed"), 0, is_known=.true.)
allocate (lib)
call lib%init (var_str ("lib_cmd5"))
call global%add_prclib (lib)
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = "Test"')
call ifile_append (ifile, 'process t5 = s, s => s, s')
call ifile_append (ifile, 'compile')
call ifile_append (ifile, 'iterations = 1:1000')
call ifile_append (ifile, 'integrate (t5)')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call reset_interaction_counter ()
call command_list%execute (global)
call global%it_list%write (u)
write (u, "(A)")
call global%process_stack%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_5"
end subroutine commands_5
@ %def commands_5
@
\subsubsection{Variables}
Set intrinsic and user-defined variables.
<<Commands: execute tests>>=
call test (commands_6, "commands_6", &
"variables", &
u, results)
<<Commands: test declarations>>=
public :: commands_6
<<Commands: tests>>=
subroutine commands_6 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_6"
write (u, "(A)") "* Purpose: define and set variables"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
call global%write_vars (u, [ &
var_str ("$run_id"), &
var_str ("?unweighted"), &
var_str ("sqrts")])
write (u, "(A)")
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, '$run_id = "run1"')
call ifile_append (ifile, '?unweighted = false')
call ifile_append (ifile, 'sqrts = 1000')
call ifile_append (ifile, 'int j = 10')
call ifile_append (ifile, 'real x = 1000.')
call ifile_append (ifile, 'complex z = 5')
call ifile_append (ifile, 'string $text = "abcd"')
call ifile_append (ifile, 'logical ?flag = true')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%write_vars (u, [ &
var_str ("$run_id"), &
var_str ("?unweighted"), &
var_str ("sqrts"), &
var_str ("j"), &
var_str ("x"), &
var_str ("z"), &
var_str ("$text"), &
var_str ("?flag")])
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call syntax_cmd_list_final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_6"
end subroutine commands_6
@ %def commands_6
@
\subsubsection{Process library}
Open process libraries explicitly.
<<Commands: execute tests>>=
call test (commands_7, "commands_7", &
"process library", &
u, results)
<<Commands: test declarations>>=
public :: commands_7
<<Commands: tests>>=
subroutine commands_7 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_7"
write (u, "(A)") "* Purpose: declare process libraries"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
call global%var_list%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
global%os_data%fc = "Fortran-compiler"
global%os_data%fcflags = "Fortran-flags"
global%os_data%fclibs = "Fortran-libs"
write (u, "(A)")
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'library = "lib_cmd7_1"')
call ifile_append (ifile, 'library = "lib_cmd7_2"')
call ifile_append (ifile, 'library = "lib_cmd7_1"')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%write_libraries (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call syntax_cmd_list_final ()
call global%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_7"
end subroutine commands_7
@ %def commands_7
@
\subsubsection{Generate events}
Read a model, then declare a process, compile the library, and
generate weighted events. We take the
default ([[unit_test]]) method and use the simplest methods of
phase-space parameterization and integration.
<<Commands: execute tests>>=
call test (commands_8, "commands_8", &
"event generation", &
u, results)
<<Commands: test declarations>>=
public :: commands_8
<<Commands: tests>>=
subroutine commands_8 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
type(prclib_entry_t), pointer :: lib
write (u, "(A)") "* Test output: commands_8"
write (u, "(A)") "* Purpose: define process, integrate, generate events"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call global%global_init ()
call global%init_fallback_model &
(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
call global%var_list%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known=.true.)
call global%var_list%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known=.true.)
call global%var_list%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known=.true.)
call global%var_list%set_log (var_str ("?vis_history"),&
.false., is_known=.true.)
call global%var_list%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%var_list%set_real (var_str ("sqrts"), &
1000._default, is_known=.true.)
allocate (lib)
call lib%init (var_str ("lib_cmd8"))
call global%add_prclib (lib)
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = "Test"')
call ifile_append (ifile, 'process commands_8_p = s, s => s, s')
call ifile_append (ifile, 'compile')
call ifile_append (ifile, 'iterations = 1:1000')
call ifile_append (ifile, 'integrate (commands_8_p)')
call ifile_append (ifile, '?unweighted = false')
call ifile_append (ifile, 'n_events = 3')
call ifile_append (ifile, '?read_raw = false')
call ifile_append (ifile, 'simulate (commands_8_p)')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
call command_list%execute (global)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_8"
end subroutine commands_8
@ %def commands_8
@
\subsubsection{Define cuts}
Declare a cut expression.
<<Commands: execute tests>>=
call test (commands_9, "commands_9", &
"cuts", &
u, results)
<<Commands: test declarations>>=
public :: commands_9
<<Commands: tests>>=
subroutine commands_9 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
type(string_t), dimension(0) :: no_vars
write (u, "(A)") "* Test output: commands_9"
write (u, "(A)") "* Purpose: define cuts"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'cuts = all Pt > 0 [particle]')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%write (u, vars = no_vars)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_9"
end subroutine commands_9
@ %def commands_9
@
\subsubsection{Beams}
Define beam setup.
<<Commands: execute tests>>=
call test (commands_10, "commands_10", &
"beams", &
u, results)
<<Commands: test declarations>>=
public :: commands_10
<<Commands: tests>>=
subroutine commands_10 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_10"
write (u, "(A)") "* Purpose: define beams"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = QCD')
call ifile_append (ifile, 'sqrts = 1000')
call ifile_append (ifile, 'beams = p, p')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%write_beams (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_10"
end subroutine commands_10
@ %def commands_10
@
\subsubsection{Structure functions}
Define beam setup with structure functions
<<Commands: execute tests>>=
call test (commands_11, "commands_11", &
"structure functions", &
u, results)
<<Commands: test declarations>>=
public :: commands_11
<<Commands: tests>>=
subroutine commands_11 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_11"
write (u, "(A)") "* Purpose: define beams with structure functions"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = QCD')
call ifile_append (ifile, 'sqrts = 1100')
call ifile_append (ifile, 'beams = p, p => lhapdf => pdf_builtin, isr')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%write_beams (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_11"
end subroutine commands_11
@ %def commands_11
@
\subsubsection{Rescan events}
Read a model, then declare a process, compile the library, and
generate weighted events. We take the
default ([[unit_test]]) method and use the simplest methods of
phase-space parameterization and integration. Then, rescan the
generated event sample.
<<Commands: execute tests>>=
call test (commands_12, "commands_12", &
"event rescanning", &
u, results)
<<Commands: test declarations>>=
public :: commands_12
<<Commands: tests>>=
subroutine commands_12 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
type(prclib_entry_t), pointer :: lib
write (u, "(A)") "* Test output: commands_12"
write (u, "(A)") "* Purpose: generate events and rescan"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call global%global_init ()
call global%var_list%append_log (&
var_str ("?rebuild_phase_space"), .false., &
intrinsic=.true.)
call global%var_list%append_log (&
var_str ("?rebuild_grids"), .false., &
intrinsic=.true.)
call global%init_fallback_model &
(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
call global%var_list%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known=.true.)
call global%var_list%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known=.true.)
call global%var_list%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known=.true.)
call global%var_list%set_log (var_str ("?vis_history"),&
.false., is_known=.true.)
call global%var_list%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%var_list%set_real (var_str ("sqrts"), &
1000._default, is_known=.true.)
allocate (lib)
call lib%init (var_str ("lib_cmd12"))
call global%add_prclib (lib)
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = "Test"')
call ifile_append (ifile, 'process commands_12_p = s, s => s, s')
call ifile_append (ifile, 'compile')
call ifile_append (ifile, 'iterations = 1:1000')
call ifile_append (ifile, 'integrate (commands_12_p)')
call ifile_append (ifile, '?unweighted = false')
call ifile_append (ifile, 'n_events = 3')
call ifile_append (ifile, '?read_raw = false')
call ifile_append (ifile, 'simulate (commands_12_p)')
call ifile_append (ifile, '?write_raw = false')
call ifile_append (ifile, 'rescan "commands_12_p" (commands_12_p)')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
call command_list%execute (global)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_12"
end subroutine commands_12
@ %def commands_12
@
\subsubsection{Event Files}
Set output formats for event files.
<<Commands: execute tests>>=
call test (commands_13, "commands_13", &
"event output formats", &
u, results)
<<Commands: test declarations>>=
public :: commands_13
<<Commands: tests>>=
subroutine commands_13 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
type(prclib_entry_t), pointer :: lib
logical :: exist
write (u, "(A)") "* Test output: commands_13"
write (u, "(A)") "* Purpose: generate events and rescan"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call global%global_init ()
call global%init_fallback_model &
(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
call global%var_list%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known=.true.)
call global%var_list%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known=.true.)
call global%var_list%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known=.true.)
call global%var_list%set_real (var_str ("sqrts"), &
1000._default, is_known=.true.)
call global%var_list%set_log (var_str ("?vis_history"),&
.false., is_known=.true.)
call global%var_list%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
allocate (lib)
call lib%init (var_str ("lib_cmd13"))
call global%add_prclib (lib)
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = "Test"')
call ifile_append (ifile, 'process commands_13_p = s, s => s, s')
call ifile_append (ifile, 'compile')
call ifile_append (ifile, 'iterations = 1:1000')
call ifile_append (ifile, 'integrate (commands_13_p)')
call ifile_append (ifile, '?unweighted = false')
call ifile_append (ifile, 'n_events = 1')
call ifile_append (ifile, '?read_raw = false')
call ifile_append (ifile, 'sample_format = weight_stream')
call ifile_append (ifile, 'simulate (commands_13_p)')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
call command_list%execute (global)
write (u, "(A)")
write (u, "(A)") "* Verify output files"
write (u, "(A)")
inquire (file = "commands_13_p.evx", exist = exist)
if (exist) write (u, "(1x,A)") "raw"
inquire (file = "commands_13_p.weights.dat", exist = exist)
if (exist) write (u, "(1x,A)") "weight_stream"
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_13"
end subroutine commands_13
@ %def commands_13
@
\subsubsection{Compile Empty Libraries}
(This is a regression test:) Declare two empty libraries and compile them.
<<Commands: execute tests>>=
call test (commands_14, "commands_14", &
"empty libraries", &
u, results)
<<Commands: test declarations>>=
public :: commands_14
<<Commands: tests>>=
subroutine commands_14 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_14"
write (u, "(A)") "* Purpose: define and compile empty libraries"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = "Test"')
call ifile_append (ifile, 'library = "lib1"')
call ifile_append (ifile, 'library = "lib2"')
call ifile_append (ifile, 'compile ()')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%prclib_stack%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_14"
end subroutine commands_14
@ %def commands_14
@
\subsubsection{Compile Process}
Read a model, then declare a process and compile the library. The process
library is allocated explicitly. For the process definition, We take the
default ([[unit_test]]) method. There is no external code, so compilation of
the library is merely a formal status change.
<<Commands: execute tests>>=
call test (commands_15, "commands_15", &
"compilation", &
u, results)
<<Commands: test declarations>>=
public :: commands_15
<<Commands: tests>>=
subroutine commands_15 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
type(prclib_entry_t), pointer :: lib
write (u, "(A)") "* Test output: commands_15"
write (u, "(A)") "* Purpose: define process and compile library"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call global%global_init ()
call global%var_list%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known=.true.)
call global%var_list%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known=.true.)
call global%var_list%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known=.true.)
call global%var_list%set_real (var_str ("sqrts"), &
1000._default, is_known=.true.)
call global%var_list%set_log (var_str ("?vis_history"),&
.false., is_known=.true.)
call global%var_list%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
allocate (lib)
call lib%init (var_str ("lib_cmd15"))
call global%add_prclib (lib)
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = "Test"')
call ifile_append (ifile, 'process t15 = s, s => s, s')
call ifile_append (ifile, 'iterations = 1:1000')
call ifile_append (ifile, 'integrate (t15)')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%prclib_stack%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_15"
end subroutine commands_15
@ %def commands_15
@
\subsubsection{Observable}
Declare an observable, fill it and display.
<<Commands: execute tests>>=
call test (commands_16, "commands_16", &
"observables", &
u, results)
<<Commands: test declarations>>=
public :: commands_16
<<Commands: tests>>=
subroutine commands_16 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_16"
write (u, "(A)") "* Purpose: declare an observable"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, '$obs_label = "foo"')
call ifile_append (ifile, '$obs_unit = "cm"')
call ifile_append (ifile, '$title = "Observable foo"')
call ifile_append (ifile, '$description = "This is observable foo"')
call ifile_append (ifile, 'observable foo')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Record two data items"
write (u, "(A)")
call analysis_record_data (var_str ("foo"), 1._default)
call analysis_record_data (var_str ("foo"), 3._default)
write (u, "(A)") "* Display analysis store"
write (u, "(A)")
call analysis_write (u, verbose=.true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call analysis_final ()
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_16"
end subroutine commands_16
@ %def commands_16
@
\subsubsection{Histogram}
Declare a histogram, fill it and display.
<<Commands: execute tests>>=
call test (commands_17, "commands_17", &
"histograms", &
u, results)
<<Commands: test declarations>>=
public :: commands_17
<<Commands: tests>>=
subroutine commands_17 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
type(string_t), dimension(3) :: name
integer :: i
write (u, "(A)") "* Test output: commands_17"
write (u, "(A)") "* Purpose: declare histograms"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, '$obs_label = "foo"')
call ifile_append (ifile, '$obs_unit = "cm"')
call ifile_append (ifile, '$title = "Histogram foo"')
call ifile_append (ifile, '$description = "This is histogram foo"')
call ifile_append (ifile, 'histogram foo (0,5,1)')
call ifile_append (ifile, '$title = "Histogram bar"')
call ifile_append (ifile, '$description = "This is histogram bar"')
call ifile_append (ifile, 'n_bins = 2')
call ifile_append (ifile, 'histogram bar (0,5)')
call ifile_append (ifile, '$title = "Histogram gee"')
call ifile_append (ifile, '$description = "This is histogram gee"')
call ifile_append (ifile, '?normalize_bins = true')
call ifile_append (ifile, 'histogram gee (0,5)')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Record two data items"
write (u, "(A)")
name(1) = "foo"
name(2) = "bar"
name(3) = "gee"
do i = 1, 3
call analysis_record_data (name(i), 0.1_default, &
weight = 0.25_default)
call analysis_record_data (name(i), 3.1_default)
call analysis_record_data (name(i), 4.1_default, &
excess = 0.5_default)
call analysis_record_data (name(i), 7.1_default)
end do
write (u, "(A)") "* Display analysis store"
write (u, "(A)")
call analysis_write (u, verbose=.true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call analysis_final ()
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_17"
end subroutine commands_17
@ %def commands_17
@
\subsubsection{Plot}
Declare a plot, fill it and display contents.
<<Commands: execute tests>>=
call test (commands_18, "commands_18", &
"plots", &
u, results)
<<Commands: test declarations>>=
public :: commands_18
<<Commands: tests>>=
subroutine commands_18 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_18"
write (u, "(A)") "* Purpose: declare a plot"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, '$obs_label = "foo"')
call ifile_append (ifile, '$obs_unit = "cm"')
call ifile_append (ifile, '$title = "Plot foo"')
call ifile_append (ifile, '$description = "This is plot foo"')
call ifile_append (ifile, '$x_label = "x axis"')
call ifile_append (ifile, '$y_label = "y axis"')
call ifile_append (ifile, '?x_log = false')
call ifile_append (ifile, '?y_log = true')
call ifile_append (ifile, 'x_min = -1')
call ifile_append (ifile, 'x_max = 1')
call ifile_append (ifile, 'y_min = 0.1')
call ifile_append (ifile, 'y_max = 1000')
call ifile_append (ifile, 'plot foo')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Record two data items"
write (u, "(A)")
call analysis_record_data (var_str ("foo"), 0._default, 20._default, &
xerr = 0.25_default)
call analysis_record_data (var_str ("foo"), 0.5_default, 0.2_default, &
yerr = 0.07_default)
call analysis_record_data (var_str ("foo"), 3._default, 2._default)
write (u, "(A)") "* Display analysis store"
write (u, "(A)")
call analysis_write (u, verbose=.true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call analysis_final ()
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_18"
end subroutine commands_18
@ %def commands_18
@
\subsubsection{Graph}
Combine two (empty) plots to a graph.
<<Commands: execute tests>>=
call test (commands_19, "commands_19", &
"graphs", &
u, results)
<<Commands: test declarations>>=
public :: commands_19
<<Commands: tests>>=
subroutine commands_19 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_19"
write (u, "(A)") "* Purpose: combine two plots to a graph"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'plot a')
call ifile_append (ifile, 'plot b')
call ifile_append (ifile, '$title = "Graph foo"')
call ifile_append (ifile, '$description = "This is graph foo"')
call ifile_append (ifile, 'graph foo = a & b')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Display analysis object"
write (u, "(A)")
call analysis_write (var_str ("foo"), u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call analysis_final ()
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_19"
end subroutine commands_19
@ %def commands_19
@
\subsubsection{Record Data}
Record data in previously allocated analysis objects.
<<Commands: execute tests>>=
call test (commands_20, "commands_20", &
"record data", &
u, results)
<<Commands: test declarations>>=
public :: commands_20
<<Commands: tests>>=
subroutine commands_20 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_20"
write (u, "(A)") "* Purpose: record data"
write (u, "(A)")
write (u, "(A)") "* Initialization: create observable, histogram, plot"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
call analysis_init_observable (var_str ("o"))
call analysis_init_histogram (var_str ("h"), 0._default, 1._default, 3, &
normalize_bins = .false.)
call analysis_init_plot (var_str ("p"))
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'record o (1.234)')
call ifile_append (ifile, 'record h (0.5)')
call ifile_append (ifile, 'record p (1, 2)')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Display analysis object"
write (u, "(A)")
call analysis_write (u, verbose = .true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call analysis_final ()
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_20"
end subroutine commands_20
@ %def commands_20
@
\subsubsection{Analysis}
Declare an analysis expression and use it to fill an observable during
event generation.
<<Commands: execute tests>>=
call test (commands_21, "commands_21", &
"analysis expression", &
u, results)
<<Commands: test declarations>>=
public :: commands_21
<<Commands: tests>>=
subroutine commands_21 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
type(prclib_entry_t), pointer :: lib
write (u, "(A)") "* Test output: commands_21"
write (u, "(A)") "* Purpose: create and use analysis expression"
write (u, "(A)")
write (u, "(A)") "* Initialization: create observable"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call global%global_init ()
call global%init_fallback_model &
(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
call global%var_list%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known=.true.)
call global%var_list%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known=.true.)
call global%var_list%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known=.true.)
call global%var_list%set_log (var_str ("?vis_history"),&
.false., is_known=.true.)
call global%var_list%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%var_list%set_real (var_str ("sqrts"), &
1000._default, is_known=.true.)
allocate (lib)
call lib%init (var_str ("lib_cmd8"))
call global%add_prclib (lib)
call analysis_init_observable (var_str ("m"))
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = "Test"')
call ifile_append (ifile, 'process commands_21_p = s, s => s, s')
call ifile_append (ifile, 'compile')
call ifile_append (ifile, 'iterations = 1:100')
call ifile_append (ifile, 'integrate (commands_21_p)')
call ifile_append (ifile, '?unweighted = true')
call ifile_append (ifile, 'n_events = 3')
call ifile_append (ifile, '?read_raw = false')
call ifile_append (ifile, 'observable m')
call ifile_append (ifile, 'analysis = record m (eval M [s])')
call ifile_append (ifile, 'simulate (commands_21_p)')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Display analysis object"
write (u, "(A)")
call analysis_write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call analysis_final ()
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_21"
end subroutine commands_21
@ %def commands_21
@
\subsubsection{Write Analysis}
Write accumulated analysis data to file.
<<Commands: execute tests>>=
call test (commands_22, "commands_22", &
"write analysis", &
u, results)
<<Commands: test declarations>>=
public :: commands_22
<<Commands: tests>>=
subroutine commands_22 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
integer :: u_file, iostat
logical :: exist
character(80) :: buffer
write (u, "(A)") "* Test output: commands_22"
write (u, "(A)") "* Purpose: write analysis data"
write (u, "(A)")
write (u, "(A)") "* Initialization: create observable"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
call analysis_init_observable (var_str ("m"))
call analysis_record_data (var_str ("m"), 125._default)
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, '$out_file = "commands_22.dat"')
call ifile_append (ifile, 'write_analysis')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Display analysis data"
write (u, "(A)")
inquire (file = "commands_22.dat", exist = exist)
if (.not. exist) then
write (u, "(A)") "ERROR: File commands_22.dat not found"
return
end if
u_file = free_unit ()
open (u_file, file = "commands_22.dat", &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call analysis_final ()
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_22"
end subroutine commands_22
@ %def commands_22
@
\subsubsection{Compile Analysis}
Write accumulated analysis data to file and compile.
<<Commands: execute tests>>=
if (MPOST_AVAILABLE) then
call test (commands_23, "commands_23", &
"compile analysis", &
u, results)
end if
<<Commands: test declarations>>=
public :: commands_23
<<Commands: tests>>=
subroutine commands_23 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
integer :: u_file, iostat
character(256) :: buffer
logical :: exist
type(graph_options_t) :: graph_options
write (u, "(A)") "* Test output: commands_23"
write (u, "(A)") "* Purpose: write and compile analysis data"
write (u, "(A)")
write (u, "(A)") "* Initialization: create and fill histogram"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
call graph_options%init ()
call graph_options%set (title = var_str ("Histogram for test: commands 23"), &
description = var_str ("This is a test."), &
width_mm = 125, height_mm = 85)
call analysis_init_histogram (var_str ("h"), &
0._default, 10._default, 2._default, .false., &
graph_options = graph_options)
call analysis_record_data (var_str ("h"), 1._default)
call analysis_record_data (var_str ("h"), 1._default)
call analysis_record_data (var_str ("h"), 1._default)
call analysis_record_data (var_str ("h"), 1._default)
call analysis_record_data (var_str ("h"), 3._default)
call analysis_record_data (var_str ("h"), 3._default)
call analysis_record_data (var_str ("h"), 3._default)
call analysis_record_data (var_str ("h"), 5._default)
call analysis_record_data (var_str ("h"), 7._default)
call analysis_record_data (var_str ("h"), 7._default)
call analysis_record_data (var_str ("h"), 7._default)
call analysis_record_data (var_str ("h"), 7._default)
call analysis_record_data (var_str ("h"), 9._default)
call analysis_record_data (var_str ("h"), 9._default)
call analysis_record_data (var_str ("h"), 9._default)
call analysis_record_data (var_str ("h"), 9._default)
call analysis_record_data (var_str ("h"), 9._default)
call analysis_record_data (var_str ("h"), 9._default)
call analysis_record_data (var_str ("h"), 9._default)
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, '$out_file = "commands_23.dat"')
call ifile_append (ifile, 'compile_analysis')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Delete Postscript output"
write (u, "(A)")
inquire (file = "commands_23.ps", exist = exist)
if (exist) then
u_file = free_unit ()
open (u_file, file = "commands_23.ps", action = "write", status = "old")
close (u_file, status = "delete")
end if
inquire (file = "commands_23.ps", exist = exist)
write (u, "(1x,A,L1)") "Postcript output exists = ", exist
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* TeX file"
write (u, "(A)")
inquire (file = "commands_23.tex", exist = exist)
if (.not. exist) then
write (u, "(A)") "ERROR: File commands_23.tex not found"
return
end if
u_file = free_unit ()
open (u_file, file = "commands_23.tex", &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, *)
inquire (file = "commands_23.ps", exist = exist)
write (u, "(1x,A,L1)") "Postcript output exists = ", exist
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call analysis_final ()
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_23"
end subroutine commands_23
@ %def commands_23
@
\subsubsection{Histogram}
Declare a histogram, fill it and display.
<<Commands: execute tests>>=
call test (commands_24, "commands_24", &
"drawing options", &
u, results)
<<Commands: test declarations>>=
public :: commands_24
<<Commands: tests>>=
subroutine commands_24 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_24"
write (u, "(A)") "* Purpose: check graph and drawing options"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, '$title = "Title"')
call ifile_append (ifile, '$description = "Description"')
call ifile_append (ifile, '$x_label = "X Label"')
call ifile_append (ifile, '$y_label = "Y Label"')
call ifile_append (ifile, 'graph_width_mm = 111')
call ifile_append (ifile, 'graph_height_mm = 222')
call ifile_append (ifile, 'x_min = -11')
call ifile_append (ifile, 'x_max = 22')
call ifile_append (ifile, 'y_min = -33')
call ifile_append (ifile, 'y_max = 44')
call ifile_append (ifile, '$gmlcode_bg = "GML Code BG"')
call ifile_append (ifile, '$gmlcode_fg = "GML Code FG"')
call ifile_append (ifile, '$fill_options = "Fill Options"')
call ifile_append (ifile, '$draw_options = "Draw Options"')
call ifile_append (ifile, '$err_options = "Error Options"')
call ifile_append (ifile, '$symbol = "Symbol"')
call ifile_append (ifile, 'histogram foo (0,1)')
call ifile_append (ifile, 'plot bar')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Display analysis store"
write (u, "(A)")
call analysis_write (u, verbose=.true.)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call analysis_final ()
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_24"
end subroutine commands_24
@ %def commands_24
@
\subsubsection{Local Environment}
Declare a local environment.
<<Commands: execute tests>>=
call test (commands_25, "commands_25", &
"local process environment", &
u, results)
<<Commands: test declarations>>=
public :: commands_25
<<Commands: tests>>=
subroutine commands_25 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_25"
write (u, "(A)") "* Purpose: declare local environment for process"
write (u, "(A)")
call syntax_model_file_init ()
call syntax_cmd_list_init ()
call global%global_init ()
call global%var_list%set_log (var_str ("?omega_openmp"), &
.false., is_known = .true.)
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'library = "commands_25_lib"')
call ifile_append (ifile, 'model = "Test"')
call ifile_append (ifile, 'process commands_25_p1 = g, g => g, g &
&{ model = "QCD" }')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%write_libraries (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_25"
end subroutine commands_25
@ %def commands_25
@
\subsubsection{Alternative Setups}
Declare a list of alternative setups.
<<Commands: execute tests>>=
call test (commands_26, "commands_26", &
"alternative setups", &
u, results)
<<Commands: test declarations>>=
public :: commands_26
<<Commands: tests>>=
subroutine commands_26 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_26"
write (u, "(A)") "* Purpose: declare alternative setups for simulation"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'int i = 0')
call ifile_append (ifile, 'alt_setup = ({ i = 1 }, { i = 2 })')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%write_expr (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_26"
end subroutine commands_26
@ %def commands_26
@
\subsubsection{Unstable Particle}
Define decay processes and declare a particle as unstable. Also check
the commands stable, polarized, unpolarized.
<<Commands: execute tests>>=
call test (commands_27, "commands_27", &
"unstable and polarized particles", &
u, results)
<<Commands: test declarations>>=
public :: commands_27
<<Commands: tests>>=
subroutine commands_27 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
type(prclib_entry_t), pointer :: lib
write (u, "(A)") "* Test output: commands_27"
write (u, "(A)") "* Purpose: modify particle properties"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call global%global_init ()
call global%var_list%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known=.true.)
call global%var_list%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known=.true.)
call global%var_list%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known=.true.)
call global%var_list%set_log (var_str ("?vis_history"),&
.false., is_known=.true.)
call global%var_list%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
allocate (lib)
call lib%init (var_str ("commands_27_lib"))
call global%add_prclib (lib)
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = "Test"')
call ifile_append (ifile, 'ff = 0.4')
call ifile_append (ifile, 'process d1 = s => f, fbar')
call ifile_append (ifile, 'unstable s (d1)')
call ifile_append (ifile, 'polarized f, fbar')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Show model"
write (u, "(A)")
call global%model%write (u)
write (u, "(A)")
write (u, "(A)") "* Extra Input"
write (u, "(A)")
call ifile_final (ifile)
call ifile_append (ifile, '?diagonal_decay = true')
call ifile_append (ifile, 'unstable s (d1)')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%final ()
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Show model"
write (u, "(A)")
call global%model%write (u)
write (u, "(A)")
write (u, "(A)") "* Extra Input"
write (u, "(A)")
call ifile_final (ifile)
call ifile_append (ifile, '?isotropic_decay = true')
call ifile_append (ifile, 'unstable s (d1)')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%final ()
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Show model"
write (u, "(A)")
call global%model%write (u)
write (u, "(A)")
write (u, "(A)") "* Extra Input"
write (u, "(A)")
call ifile_final (ifile)
call ifile_append (ifile, 'stable s')
call ifile_append (ifile, 'unpolarized f')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%final ()
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Show model"
write (u, "(A)")
call global%model%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_model_file_init ()
call syntax_cmd_list_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_27"
end subroutine commands_27
@ %def commands_27
@
\subsubsection{Quit the program}
Quit the program.
<<Commands: execute tests>>=
call test (commands_28, "commands_28", &
"quit", &
u, results)
<<Commands: test declarations>>=
public :: commands_28
<<Commands: tests>>=
subroutine commands_28 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root1, pn_root2
type(string_t), dimension(0) :: no_vars
write (u, "(A)") "* Test output: commands_28"
write (u, "(A)") "* Purpose: quit the program"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file: quit without code"
write (u, "(A)")
call ifile_append (ifile, 'quit')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root1, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root1, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%write (u, vars = no_vars)
write (u, "(A)")
write (u, "(A)") "* Input file: quit with code"
write (u, "(A)")
call ifile_final (ifile)
call command_list%final ()
call ifile_append (ifile, 'quit ( 3 + 4 )')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root2, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root2, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%write (u, vars = no_vars)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_28"
end subroutine commands_28
@ %def commands_28
@
\subsubsection{SLHA interface}
Testing commands steering the SLHA interface.
<<Commands: execute tests>>=
call test (commands_29, "commands_29", &
"SLHA interface", &
u, results)
<<Commands: test declarations>>=
public :: commands_29
<<Commands: tests>>=
subroutine commands_29 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(var_list_t), pointer :: model_vars
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_29"
write (u, "(A)") "* Purpose: test SLHA interface"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call syntax_model_file_init ()
call syntax_slha_init ()
call global%global_init ()
write (u, "(A)") "* Model MSSM, read SLHA file"
write (u, "(A)")
call ifile_append (ifile, 'model = "MSSM"')
call ifile_append (ifile, '?slha_read_decays = true')
call ifile_append (ifile, 'read_slha ("sps1ap_decays.slha")')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Model MSSM, default values:"
write (u, "(A)")
call global%model%write (u, verbose = .false., &
show_vertices = .false., show_particles = .false.)
write (u, "(A)")
write (u, "(A)") "* Selected global variables"
write (u, "(A)")
model_vars => global%model%get_var_list_ptr ()
call model_vars%write_var (var_str ("mch1"), u)
call model_vars%write_var (var_str ("wch1"), u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)") "* Model MSSM, values from SLHA file"
write (u, "(A)")
call global%model%write (u, verbose = .false., &
show_vertices = .false., show_particles = .false.)
write (u, "(A)")
write (u, "(A)") "* Selected global variables"
write (u, "(A)")
model_vars => global%model%get_var_list_ptr ()
call model_vars%write_var (var_str ("mch1"), u)
call model_vars%write_var (var_str ("wch1"), u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_slha_final ()
call syntax_model_file_final ()
call syntax_cmd_list_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_29"
end subroutine commands_29
@ %def commands_29
@
\subsubsection{Expressions for scales}
Declare a scale, factorization scale or factorization scale expression.
<<Commands: execute tests>>=
call test (commands_30, "commands_30", &
"scales", &
u, results)
<<Commands: test declarations>>=
public :: commands_30
<<Commands: tests>>=
subroutine commands_30 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_30"
write (u, "(A)") "* Purpose: define scales"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'scale = 200 GeV')
call ifile_append (ifile, &
'factorization_scale = eval Pt [particle]')
call ifile_append (ifile, &
'renormalization_scale = eval E [particle]')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%write_expr (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_30"
end subroutine commands_30
@ %def commands_30
@
\subsubsection{Weight and reweight expressions}
Declare an expression for event weights and reweighting.
<<Commands: execute tests>>=
call test (commands_31, "commands_31", &
"event weights/reweighting", &
u, results)
<<Commands: test declarations>>=
public :: commands_31
<<Commands: tests>>=
subroutine commands_31 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_31"
write (u, "(A)") "* Purpose: define weight/reweight"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'weight = eval Pz [particle]')
call ifile_append (ifile, 'reweight = eval M2 [particle]')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%write_expr (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_31"
end subroutine commands_31
@ %def commands_31
@
\subsubsection{Selecting events}
Declare an expression for selecting events in an analysis.
<<Commands: execute tests>>=
call test (commands_32, "commands_32", &
"event selection", &
u, results)
<<Commands: test declarations>>=
public :: commands_32
<<Commands: tests>>=
subroutine commands_32 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
write (u, "(A)") "* Test output: commands_32"
write (u, "(A)") "* Purpose: define selection"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'selection = any PDG == 13 [particle]')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
call global%write_expr (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_32"
end subroutine commands_32
@ %def commands_32
@
\subsubsection{Executing shell commands}
Execute a shell command.
<<Commands: execute tests>>=
call test (commands_33, "commands_33", &
"execute shell command", &
u, results)
<<Commands: test declarations>>=
public :: commands_33
<<Commands: tests>>=
subroutine commands_33 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
integer :: u_file, iostat
character(3) :: buffer
write (u, "(A)") "* Test output: commands_33"
write (u, "(A)") "* Purpose: execute shell command"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'exec ("echo foo >> bar")')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root, u)
write (u, "(A)")
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
u_file = free_unit ()
open (u_file, file = "bar", &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (iostat /= 0) exit
end do
write (u, "(A,A)") "should be 'foo': ", trim (buffer)
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_33"
end subroutine commands_33
@ %def commands_33
@
\subsubsection{Callback}
Instead of an explicit write, use the callback feature to write the
analysis file during event generation. We generate 4 events and
arrange that the callback is executed while writing the 3rd event.
<<Commands: execute tests>>=
call test (commands_34, "commands_34", &
"analysis via callback", &
u, results)
<<Commands: test declarations>>=
public :: commands_34
<<Commands: tests>>=
subroutine commands_34 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(command_list_t), target :: command_list
type(rt_data_t), target :: global
type(parse_node_t), pointer :: pn_root
type(prclib_entry_t), pointer :: lib
type(event_callback_34_t) :: event_callback
write (u, "(A)") "* Test output: commands_34"
write (u, "(A)") "* Purpose: write analysis data"
write (u, "(A)")
write (u, "(A)") "* Initialization: create observable"
write (u, "(A)")
call syntax_cmd_list_init ()
call global%global_init ()
call syntax_model_file_init ()
call global%global_init ()
call global%init_fallback_model &
(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
call global%var_list%set_string (var_str ("$method"), &
var_str ("unit_test"), is_known=.true.)
call global%var_list%set_string (var_str ("$phs_method"), &
var_str ("single"), is_known=.true.)
call global%var_list%set_string (var_str ("$integration_method"),&
var_str ("midpoint"), is_known=.true.)
call global%var_list%set_real (var_str ("sqrts"), &
1000._default, is_known=.true.)
call global%var_list%set_log (var_str ("?vis_history"),&
.false., is_known=.true.)
call global%var_list%set_log (var_str ("?integration_timer"),&
.false., is_known = .true.)
call global%var_list%set_int (var_str ("seed"), 0, is_known=.true.)
allocate (lib)
call lib%init (var_str ("lib_cmd34"))
call global%add_prclib (lib)
write (u, "(A)") "* Prepare callback for writing analysis to I/O unit"
write (u, "(A)")
event_callback%u = u
call global%set_event_callback (event_callback)
write (u, "(A)") "* Input file"
write (u, "(A)")
call ifile_append (ifile, 'model = "Test"')
call ifile_append (ifile, 'process commands_34_p = s, s => s, s')
call ifile_append (ifile, 'compile')
call ifile_append (ifile, 'iterations = 1:1000')
call ifile_append (ifile, 'integrate (commands_34_p)')
call ifile_append (ifile, 'observable sq')
call ifile_append (ifile, 'analysis = record sq (sqrts)')
call ifile_append (ifile, 'n_events = 4')
call ifile_append (ifile, 'event_callback_interval = 3')
call ifile_append (ifile, 'simulate (commands_34_p)')
call ifile_write (ifile, u)
write (u, "(A)")
write (u, "(A)") "* Parse file"
write (u, "(A)")
call parse_ifile (ifile, pn_root)
write (u, "(A)") "* Compile command list"
write (u, "(A)")
call command_list%compile (pn_root, global)
call command_list%write (u)
write (u, "(A)")
write (u, "(A)") "* Execute command list"
write (u, "(A)")
call command_list%execute (global)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call ifile_final (ifile)
call analysis_final ()
call command_list%final ()
call global%final ()
call syntax_cmd_list_final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: commands_34"
end subroutine commands_34
@ %def commands_34
@ For this test, we invent a callback object which simply writes the
analysis file, using the standard call for this. Here we rely on the
fact that the analysis data are stored as a global entity, otherwise
we would have to access them via the event object.
<<Commands: test auxiliary types>>=
type, extends (event_callback_t) :: event_callback_34_t
private
integer :: u = 0
contains
procedure :: write => event_callback_34_write
procedure :: proc => event_callback_34
end type event_callback_34_t
@ %def event_callback_t
@ The output routine is unused. The actual callback should write the
analysis data to the output unit that we have injected into the
callback object.
<<Commands: test auxiliary>>=
subroutine event_callback_34_write (event_callback, unit)
class(event_callback_34_t), intent(in) :: event_callback
integer, intent(in), optional :: unit
end subroutine event_callback_34_write
subroutine event_callback_34 (event_callback, i, event)
class(event_callback_34_t), intent(in) :: event_callback
integer(i64), intent(in) :: i
class(generic_event_t), intent(in) :: event
call analysis_write (event_callback%u)
end subroutine event_callback_34
@ %def event_callback_34_write
@ %def event_callback_34
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Toplevel module WHIZARD}
<<[[whizard.f90]]>>=
<<File header>>
module whizard
use io_units
<<Use strings>>
use os_interface
use ifiles
use lexers
use parser
use rt_data
<<Standard module head>>
<<WHIZARD: public>>
<<WHIZARD: types>>
<<WHIZARD: variables>>
save
interface
<<WHIZARD: sub interfaces>>
end interface
end module whizard
@ %def whizard
@
<<[[whizard_sub.f90]]>>=
<<File header>>
submodule (whizard) whizard_s
use system_defs, only: VERSION_STRING
use system_defs, only: EOF, BACKSLASH
use diagnostics
use eval_trees
use models
use phs_forests
use prclib_stacks
use slha_interface
use commands
implicit none
contains
<<WHIZARD: procedures>>
end submodule whizard_s
@ %def whizard_s
@
\subsection{Options}
Here we introduce a wrapper that holds various user options, so they
can transparently be passed from the main program to the [[whizard]]
object. Most parameters are used for initializing the [[global]]
state.
<<WHIZARD: public>>=
public :: whizard_options_t
<<WHIZARD: types>>=
type :: whizard_options_t
type(string_t) :: job_id
type(string_t), dimension(:), allocatable :: pack_args
type(string_t), dimension(:), allocatable :: unpack_args
type(string_t) :: preload_model
type(string_t) :: default_lib
type(string_t) :: preload_libraries
logical :: rebuild_library = .false.
logical :: recompile_library = .false.
logical :: rebuild_phs = .false.
logical :: rebuild_grids = .false.
logical :: rebuild_events = .false.
end type whizard_options_t
@ %def whizard_options_t
@
\subsection{Parse tree stack}
We collect all parse trees that we generate in the [[whizard]] object. To
this end, we create a stack of parse trees. They must not be finalized before
the [[global]] object is finalized, because items such as a cut definition may
contain references to the parse tree from which they were generated.
<<WHIZARD: types>>=
type, extends (parse_tree_t) :: pt_entry_t
type(pt_entry_t), pointer :: previous => null ()
end type pt_entry_t
@ %def pt_entry_t
@ This is the stack. Since we always prepend, we just need the [[last]]
pointer.
<<WHIZARD: types>>=
type :: pt_stack_t
type(pt_entry_t), pointer :: last => null ()
contains
<<WHIZARD: pt stack: TBP>>
end type pt_stack_t
@ %def pt_stack_t
@ The finalizer is called at the very end.
<<WHIZARD: pt stack: TBP>>=
procedure :: final => pt_stack_final
<<WHIZARD: sub interfaces>>=
module subroutine pt_stack_final (pt_stack)
class(pt_stack_t), intent(inout) :: pt_stack
end subroutine pt_stack_final
<<WHIZARD: procedures>>=
module subroutine pt_stack_final (pt_stack)
class(pt_stack_t), intent(inout) :: pt_stack
type(pt_entry_t), pointer :: current
do while (associated (pt_stack%last))
current => pt_stack%last
pt_stack%last => current%previous
call parse_tree_final (current%parse_tree_t)
deallocate (current)
end do
end subroutine pt_stack_final
@ %def pt_stack_final
@ Create and push a new entry, keeping the previous ones.
<<WHIZARD: pt stack: TBP>>=
procedure :: push => pt_stack_push
<<WHIZARD: sub interfaces>>=
module subroutine pt_stack_push (pt_stack, parse_tree)
class(pt_stack_t), intent(inout) :: pt_stack
type(parse_tree_t), intent(out), pointer :: parse_tree
end subroutine pt_stack_push
<<WHIZARD: procedures>>=
module subroutine pt_stack_push (pt_stack, parse_tree)
class(pt_stack_t), intent(inout) :: pt_stack
type(parse_tree_t), intent(out), pointer :: parse_tree
type(pt_entry_t), pointer :: current
allocate (current)
parse_tree => current%parse_tree_t
current%previous => pt_stack%last
pt_stack%last => current
end subroutine pt_stack_push
@ %def pt_stack_push
@
\subsection{The [[whizard]] object}
An object of type [[whizard_t]] is the top-level wrapper for a
\whizard\ instance. The object holds various default
settings and the current state of the generator, the [[global]] object
of type [[rt_data_t]]. This object contains, for instance, the list
of variables and the process libraries.
Since components of the [[global]] subobject are frequently used as
targets, the [[whizard]] object should also consistently carry the
[[target]] attribute.
The various self-tests do no not use this object. They initialize
only specific subsets of the system, according to their needs.
Note: we intend to allow several concurrent instances. In the current
implementation, there are still a few obstacles to this: the model
library and the syntax tables are global variables, and the error
handling uses global state. This should be improved.
<<WHIZARD: public>>=
public :: whizard_t
<<WHIZARD: types>>=
type :: whizard_t
type(whizard_options_t) :: options
type(rt_data_t) :: global
type(pt_stack_t) :: pt_stack
contains
<<WHIZARD: whizard: TBP>>
end type whizard_t
@ %def whizard_t
@
\subsection{Initialization and finalization}
<<WHIZARD: whizard: TBP>>=
procedure :: init => whizard_init
<<WHIZARD: sub interfaces>>=
module subroutine whizard_init (whizard, options, paths, logfile)
class(whizard_t), intent(out), target :: whizard
type(whizard_options_t), intent(in) :: options
type(paths_t), intent(in), optional :: paths
type(string_t), intent(in), optional :: logfile
end subroutine whizard_init
<<WHIZARD: procedures>>=
module subroutine whizard_init (whizard, options, paths, logfile)
class(whizard_t), intent(out), target :: whizard
type(whizard_options_t), intent(in) :: options
type(paths_t), intent(in), optional :: paths
type(string_t), intent(in), optional :: logfile
call init_syntax_tables ()
whizard%options = options
call whizard%global%global_init (paths, logfile)
call whizard%init_job_id ()
call whizard%init_rebuild_flags ()
call whizard%unpack_files ()
call whizard%preload_model ()
call whizard%preload_library ()
call whizard%global%init_fallback_model &
(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
end subroutine whizard_init
@ %def whizard_init
@ Apart from the global data which have been initialized above, the
process and model lists need to be finalized.
<<WHIZARD: whizard: TBP>>=
procedure :: final => whizard_final
<<WHIZARD: sub interfaces>>=
module subroutine whizard_final (whizard)
class(whizard_t), intent(inout), target :: whizard
end subroutine whizard_final
<<WHIZARD: procedures>>=
module subroutine whizard_final (whizard)
class(whizard_t), intent(inout), target :: whizard
call whizard%global%final ()
call whizard%pt_stack%final ()
call whizard%pack_files ()
call final_syntax_tables ()
end subroutine whizard_final
@ %def whizard_final
@ Set the job ID, if nonempty. If the ID string is empty, the value remains
undefined.
<<WHIZARD: whizard: TBP>>=
procedure :: init_job_id => whizard_init_job_id
<<WHIZARD: sub interfaces>>=
module subroutine whizard_init_job_id (whizard)
class(whizard_t), intent(inout), target :: whizard
end subroutine whizard_init_job_id
<<WHIZARD: procedures>>=
module subroutine whizard_init_job_id (whizard)
class(whizard_t), intent(inout), target :: whizard
associate (var_list => whizard%global%var_list, options => whizard%options)
if (options%job_id /= "") then
call var_list%set_string (var_str ("$job_id"), &
options%job_id, is_known=.true.)
end if
end associate
end subroutine whizard_init_job_id
@ %def whizard_init_job_id
@
Set the rebuild flags. They can be specified on the command line and
set the initial value for the associated logical variables.
<<WHIZARD: whizard: TBP>>=
procedure :: init_rebuild_flags => whizard_init_rebuild_flags
<<WHIZARD: sub interfaces>>=
module subroutine whizard_init_rebuild_flags (whizard)
class(whizard_t), intent(inout), target :: whizard
end subroutine whizard_init_rebuild_flags
<<WHIZARD: procedures>>=
module subroutine whizard_init_rebuild_flags (whizard)
class(whizard_t), intent(inout), target :: whizard
associate (var_list => whizard%global%var_list, options => whizard%options)
call var_list%append_log (var_str ("?rebuild_library"), &
options%rebuild_library, intrinsic=.true.)
call var_list%append_log (var_str ("?recompile_library"), &
options%recompile_library, intrinsic=.true.)
call var_list%append_log (var_str ("?rebuild_phase_space"), &
options%rebuild_phs, intrinsic=.true.)
call var_list%append_log (var_str ("?rebuild_grids"), &
options%rebuild_grids, intrinsic=.true.)
call var_list%append_log (var_str ("?rebuild_events"), &
options%rebuild_events, intrinsic=.true.)
end associate
end subroutine whizard_init_rebuild_flags
@ %def whizard_init_rebuild_flags
@
Pack/unpack files in the working directory, if requested.
<<WHIZARD: whizard: TBP>>=
procedure :: pack_files => whizard_pack_files
procedure :: unpack_files => whizard_unpack_files
<<WHIZARD: sub interfaces>>=
module subroutine whizard_pack_files (whizard)
class(whizard_t), intent(in), target :: whizard
end subroutine whizard_pack_files
module subroutine whizard_unpack_files (whizard)
class(whizard_t), intent(in), target :: whizard
end subroutine whizard_unpack_files
<<WHIZARD: procedures>>=
module subroutine whizard_pack_files (whizard)
class(whizard_t), intent(in), target :: whizard
logical :: exist
integer :: i
type(string_t) :: file
if (allocated (whizard%options%pack_args)) then
do i = 1, size (whizard%options%pack_args)
file = whizard%options%pack_args(i)
call msg_message ("Packing file/dir '" // char (file) // "'")
exist = os_file_exist (file) .or. os_dir_exist (file)
if (exist) then
call os_pack_file (whizard%options%pack_args(i), &
whizard%global%os_data)
else
call msg_error ("File/dir '" // char (file) // "' not found")
end if
end do
end if
end subroutine whizard_pack_files
module subroutine whizard_unpack_files (whizard)
class(whizard_t), intent(in), target :: whizard
logical :: exist
integer :: i
type(string_t) :: file
if (allocated (whizard%options%unpack_args)) then
do i = 1, size (whizard%options%unpack_args)
file = whizard%options%unpack_args(i)
call msg_message ("Unpacking file '" // char (file) // "'")
exist = os_file_exist (file)
if (exist) then
call os_unpack_file (whizard%options%unpack_args(i), &
whizard%global%os_data)
else
call msg_error ("File '" // char (file) // "' not found")
end if
end do
end if
end subroutine whizard_unpack_files
@ %def whizard_pack_files
@ %def whizard_unpack_files
@
This procedure preloads a model, if a model name is given.
<<WHIZARD: whizard: TBP>>=
procedure :: preload_model => whizard_preload_model
<<WHIZARD: sub interfaces>>=
module subroutine whizard_preload_model (whizard)
class(whizard_t), intent(inout), target :: whizard
end subroutine whizard_preload_model
<<WHIZARD: procedures>>=
module subroutine whizard_preload_model (whizard)
class(whizard_t), intent(inout), target :: whizard
type(string_t) :: model_name
model_name = whizard%options%preload_model
if (model_name /= "") then
call whizard%global%read_model (model_name, whizard%global%preload_model)
whizard%global%model => whizard%global%preload_model
if (associated (whizard%global%model)) then
call whizard%global%model%link_var_list (whizard%global%var_list)
call whizard%global%var_list%set_string (var_str ("$model_name"), &
model_name, is_known = .true.)
call msg_message ("Preloaded model: " &
// char (model_name))
else
call msg_fatal ("Preloading model " // char (model_name) &
// " failed")
end if
else
call msg_message ("No model preloaded")
end if
end subroutine whizard_preload_model
@ %def whizard_preload_model
@
This procedure preloads a library, if a library name is given.
Note: This version just opens a new library with that name. It does not load
(yet) an existing library on file, as previous \whizard\ versions would do.
<<WHIZARD: whizard: TBP>>=
procedure :: preload_library => whizard_preload_library
<<WHIZARD: sub interfaces>>=
module subroutine whizard_preload_library (whizard)
class(whizard_t), intent(inout), target :: whizard
end subroutine whizard_preload_library
<<WHIZARD: procedures>>=
module subroutine whizard_preload_library (whizard)
class(whizard_t), intent(inout), target :: whizard
type(string_t) :: library_name, libs
type(string_t), dimension(:), allocatable :: libname_static
type(prclib_entry_t), pointer :: lib_entry
integer :: i
call get_prclib_static (libname_static)
do i = 1, size (libname_static)
allocate (lib_entry)
call lib_entry%init_static (libname_static(i))
call whizard%global%add_prclib (lib_entry)
end do
libs = adjustl (whizard%options%preload_libraries)
if (libs == "" .and. whizard%options%default_lib /= "") then
allocate (lib_entry)
call lib_entry%init (whizard%options%default_lib)
call whizard%global%add_prclib (lib_entry)
call msg_message ("Preloaded library: " // &
char (whizard%options%default_lib))
end if
SCAN_LIBS: do while (libs /= "")
call split (libs, library_name, " ")
if (library_name /= "") then
allocate (lib_entry)
call lib_entry%init (library_name)
call whizard%global%add_prclib (lib_entry)
call msg_message ("Preloaded library: " // char (library_name))
end if
end do SCAN_LIBS
end subroutine whizard_preload_library
@ %def whizard_preload_library
@
\subsection{Initialization and finalization: syntax tables}
Initialize/finalize the syntax tables used by WHIZARD. These are effectively
singleton objects. We introduce a module variable that tracks the
initialization status.
Without syntax tables, essentially nothing will work. Any initializer has to
call this.
<<WHIZARD: variables>>=
logical :: syntax_tables_exist = .false.
@ %def syntax_tables_exist
@
<<WHIZARD: public>>=
public :: init_syntax_tables
public :: final_syntax_tables
<<WHIZARD: sub interfaces>>=
module subroutine init_syntax_tables ()
end subroutine init_syntax_tables
module subroutine final_syntax_tables ()
end subroutine final_syntax_tables
<<WHIZARD: procedures>>=
module subroutine init_syntax_tables ()
if (.not. syntax_tables_exist) then
call syntax_model_file_init ()
call syntax_phs_forest_init ()
call syntax_pexpr_init ()
call syntax_slha_init ()
call syntax_cmd_list_init ()
syntax_tables_exist = .true.
end if
end subroutine init_syntax_tables
module subroutine final_syntax_tables ()
if (syntax_tables_exist) then
call syntax_model_file_final ()
call syntax_phs_forest_final ()
call syntax_pexpr_final ()
call syntax_slha_final ()
call syntax_cmd_list_final ()
syntax_tables_exist = .false.
end if
end subroutine final_syntax_tables
@ %def init_syntax_tables
@ %def final_syntax_tables
@ Write the syntax tables to external files.
<<WHIZARD: public>>=
public :: write_syntax_tables
<<WHIZARD: sub interfaces>>=
module subroutine write_syntax_tables ()
end subroutine write_syntax_tables
<<WHIZARD: procedures>>=
module subroutine write_syntax_tables ()
integer :: unit
character(*), parameter :: file_model = "whizard.model_file.syntax"
character(*), parameter :: file_phs = "whizard.phase_space_file.syntax"
character(*), parameter :: file_pexpr = "whizard.prt_expressions.syntax"
character(*), parameter :: file_slha = "whizard.slha.syntax"
character(*), parameter :: file_sindarin = "whizard.sindarin.syntax"
if (.not. syntax_tables_exist) call init_syntax_tables ()
unit = free_unit ()
print *, "Writing file '" // file_model // "'"
open (unit=unit, file=file_model, status="replace", action="write")
write (unit, "(A)") VERSION_STRING
write (unit, "(A)") "Syntax definition file: " // file_model
call syntax_model_file_write (unit)
close (unit)
print *, "Writing file '" // file_phs // "'"
open (unit=unit, file=file_phs, status="replace", action="write")
write (unit, "(A)") VERSION_STRING
write (unit, "(A)") "Syntax definition file: " // file_phs
call syntax_phs_forest_write (unit)
close (unit)
print *, "Writing file '" // file_pexpr // "'"
open (unit=unit, file=file_pexpr, status="replace", action="write")
write (unit, "(A)") VERSION_STRING
write (unit, "(A)") "Syntax definition file: " // file_pexpr
call syntax_pexpr_write (unit)
close (unit)
print *, "Writing file '" // file_slha // "'"
open (unit=unit, file=file_slha, status="replace", action="write")
write (unit, "(A)") VERSION_STRING
write (unit, "(A)") "Syntax definition file: " // file_slha
call syntax_slha_write (unit)
close (unit)
print *, "Writing file '" // file_sindarin // "'"
open (unit=unit, file=file_sindarin, status="replace", action="write")
write (unit, "(A)") VERSION_STRING
write (unit, "(A)") "Syntax definition file: " // file_sindarin
call syntax_cmd_list_write (unit)
close (unit)
end subroutine write_syntax_tables
@ %def write_syntax_tables
@
\subsection{Execute command lists}
Process commands given on the command line, stored as an [[ifile]]. The whole
input is read, compiled and executed as a whole.
<<WHIZARD: whizard: TBP>>=
procedure :: process_ifile => whizard_process_ifile
<<WHIZARD: sub interfaces>>=
module subroutine whizard_process_ifile (whizard, ifile, quit, quit_code)
class(whizard_t), intent(inout), target :: whizard
type(ifile_t), intent(in) :: ifile
logical, intent(out) :: quit
integer, intent(out) :: quit_code
end subroutine whizard_process_ifile
<<WHIZARD: procedures>>=
module subroutine whizard_process_ifile (whizard, ifile, quit, quit_code)
class(whizard_t), intent(inout), target :: whizard
type(ifile_t), intent(in) :: ifile
logical, intent(out) :: quit
integer, intent(out) :: quit_code
type(lexer_t), target :: lexer
type(stream_t), target :: stream
call msg_message ("Reading commands given on the command line")
call lexer_init_cmd_list (lexer)
call stream_init (stream, ifile)
call whizard%process_stream (stream, lexer, quit, quit_code)
call stream_final (stream)
call lexer_final (lexer)
end subroutine whizard_process_ifile
@ %def whizard_process_ifile
@ Process standard input as a command list. The whole input is read,
compiled and executed as a whole.
<<WHIZARD: whizard: TBP>>=
procedure :: process_stdin => whizard_process_stdin
<<WHIZARD: sub interfaces>>=
module subroutine whizard_process_stdin (whizard, quit, quit_code)
class(whizard_t), intent(inout), target :: whizard
logical, intent(out) :: quit
integer, intent(out) :: quit_code
end subroutine whizard_process_stdin
<<WHIZARD: procedures>>=
module subroutine whizard_process_stdin (whizard, quit, quit_code)
class(whizard_t), intent(inout), target :: whizard
logical, intent(out) :: quit
integer, intent(out) :: quit_code
type(lexer_t), target :: lexer
type(stream_t), target :: stream
call msg_message ("Reading commands from standard input")
call lexer_init_cmd_list (lexer)
call stream_init (stream, 5)
call whizard%process_stream (stream, lexer, quit, quit_code)
call stream_final (stream)
call lexer_final (lexer)
end subroutine whizard_process_stdin
@ %def whizard_process_stdin
@ Process a file as a command list.
<<WHIZARD: whizard: TBP>>=
procedure :: process_file => whizard_process_file
<<WHIZARD: sub interfaces>>=
module subroutine whizard_process_file (whizard, file, quit, quit_code)
class(whizard_t), intent(inout), target :: whizard
type(string_t), intent(in) :: file
logical, intent(out) :: quit
integer, intent(out) :: quit_code
end subroutine whizard_process_file
<<WHIZARD: procedures>>=
module subroutine whizard_process_file (whizard, file, quit, quit_code)
class(whizard_t), intent(inout), target :: whizard
type(string_t), intent(in) :: file
logical, intent(out) :: quit
integer, intent(out) :: quit_code
type(lexer_t), target :: lexer
type(stream_t), target :: stream
logical :: exist
call msg_message ("Reading commands from file '" // char (file) // "'")
inquire (file=char(file), exist=exist)
if (exist) then
call lexer_init_cmd_list (lexer)
call stream_init (stream, char (file))
call whizard%process_stream (stream, lexer, quit, quit_code)
call stream_final (stream)
call lexer_final (lexer)
else
call msg_error ("File '" // char (file) // "' not found")
end if
end subroutine whizard_process_file
@ %def whizard_process_file
@
<<WHIZARD: whizard: TBP>>=
procedure :: process_stream => whizard_process_stream
<<WHIZARD: sub interfaces>>=
module subroutine whizard_process_stream &
(whizard, stream, lexer, quit, quit_code)
class(whizard_t), intent(inout), target :: whizard
type(stream_t), intent(inout), target :: stream
type(lexer_t), intent(inout), target :: lexer
logical, intent(out) :: quit
integer, intent(out) :: quit_code
end subroutine whizard_process_stream
<<WHIZARD: procedures>>=
module subroutine whizard_process_stream &
(whizard, stream, lexer, quit, quit_code)
class(whizard_t), intent(inout), target :: whizard
type(stream_t), intent(inout), target :: stream
type(lexer_t), intent(inout), target :: lexer
logical, intent(out) :: quit
integer, intent(out) :: quit_code
type(parse_tree_t), pointer :: parse_tree
type(command_list_t), target :: command_list
call lexer_assign_stream (lexer, stream)
call whizard%pt_stack%push (parse_tree)
call parse_tree_init (parse_tree, syntax_cmd_list, lexer)
if (associated (parse_tree%get_root_ptr ())) then
whizard%global%lexer => lexer
call command_list%compile (parse_tree%get_root_ptr (), &
whizard%global)
end if
call whizard%global%activate ()
call command_list%execute (whizard%global)
call command_list%final ()
quit = whizard%global%quit
quit_code = whizard%global%quit_code
end subroutine whizard_process_stream
@ %def whizard_process_stream
@
\subsection{The WHIZARD shell}
This procedure implements interactive mode. One line is processed at
a time.
<<WHIZARD: whizard: TBP>>=
procedure :: shell => whizard_shell
<<WHIZARD: sub interfaces>>=
module subroutine whizard_shell (whizard, quit_code)
class(whizard_t), intent(inout), target :: whizard
integer, intent(out) :: quit_code
end subroutine whizard_shell
<<WHIZARD: procedures>>=
module subroutine whizard_shell (whizard, quit_code)
class(whizard_t), intent(inout), target :: whizard
integer, intent(out) :: quit_code
type(lexer_t), target :: lexer
type(stream_t), target :: stream
type(string_t) :: prompt1
type(string_t) :: prompt2
type(string_t) :: input
type(string_t) :: extra
integer :: last
integer :: iostat
logical :: mask_tmp
logical :: quit
call msg_message ("Launching interactive shell")
call lexer_init_cmd_list (lexer)
prompt1 = "whish? "
prompt2 = " > "
COMMAND_LOOP: do
call put (6, prompt1)
call get (5, input, iostat=iostat)
if (iostat > 0 .or. iostat == EOF) exit COMMAND_LOOP
CONTINUE_INPUT: do
last = len_trim (input)
if (extract (input, last, last) /= BACKSLASH) exit CONTINUE_INPUT
call put (6, prompt2)
call get (5, extra, iostat=iostat)
if (iostat > 0) exit COMMAND_LOOP
input = replace (input, last, extra)
end do CONTINUE_INPUT
call stream_init (stream, input)
mask_tmp = mask_fatal_errors
mask_fatal_errors = .true.
call whizard%process_stream (stream, lexer, quit, quit_code)
msg_count = 0
mask_fatal_errors = mask_tmp
call stream_final (stream)
if (quit) exit COMMAND_LOOP
end do COMMAND_LOOP
print *
call lexer_final (lexer)
end subroutine whizard_shell
@ %def whizard_shell
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Query Feature Support}
This module accesses the various optional features (modules) that
WHIZARD can support and repors on their availability.
<<[[features.f90]]>>=
module features
<<Standard module head>>
<<Features: public>>
interface
<<Features: sub interfaces>>
end interface
end module features
@ %def features
@
<<[[features_sub.f90]]>>=
<<File header>>
submodule (features) features_s
use string_utils, only: lower_case
use system_dependencies, only: WHIZARD_VERSION
<<Features: dependencies>>
implicit none
contains
<<Features: procedures>>
end submodule features_s
@ %def features_s
@
\subsection{Output}
<<Features: public>>=
public :: print_features
<<Features: sub interfaces>>=
module subroutine print_features ()
end subroutine print_features
<<Features: procedures>>=
module subroutine print_features ()
print "(A)", "WHIZARD " // WHIZARD_VERSION
print "(A)", "Build configuration:"
<<Features: config>>
print "(A)", "Optional features available in this build:"
<<Features: print>>
end subroutine print_features
@ %def print_features
@
\subsection{Query function}
<<Features: procedures>>=
subroutine check (feature, recognized, result, help)
character(*), intent(in) :: feature
logical, intent(out) :: recognized
character(*), intent(out) :: result, help
recognized = .true.
result = "no"
select case (lower_case (trim (feature)))
<<Features: cases>>
case default
recognized = .false.
end select
end subroutine check
@ %def check
@ Print this result:
<<Features: procedures>>=
subroutine print_check (feature)
character(*), intent(in) :: feature
character(16) :: f
logical :: recognized
character(10) :: result
character(48) :: help
call check (feature, recognized, result, help)
if (.not. recognized) then
result = "unknown"
help = ""
end if
f = feature
print "(2x,A,1x,A,'(',A,')')", f, result, trim (help)
end subroutine print_check
@ %def print_check
@
\subsection{Basic configuration}
<<Features: config>>=
call print_check ("precision")
<<Features: dependencies>>=
use kinds, only: default
<<Features: cases>>=
case ("precision")
write (result, "(I0)") precision (1._default)
help = "significant decimals of real/complex numbers"
@
\subsection{Optional features case by case}
<<Features: print>>=
call print_check ("OpenMP")
<<Features: dependencies>>=
use system_dependencies, only: openmp_is_active
<<Features: cases>>=
case ("openmp")
if (openmp_is_active ()) then
result = "yes"
end if
help = "OpenMP parallel execution"
@
<<Features: print>>=
call print_check ("GoSam")
<<Features: dependencies>>=
use system_dependencies, only: GOSAM_AVAILABLE
<<Features: cases>>=
case ("gosam")
if (GOSAM_AVAILABLE) then
result = "yes"
end if
help = "external NLO matrix element provider"
@
<<Features: print>>=
call print_check ("OpenLoops")
<<Features: dependencies>>=
use system_dependencies, only: OPENLOOPS_AVAILABLE
<<Features: cases>>=
case ("openloops")
if (OPENLOOPS_AVAILABLE) then
result = "yes"
end if
help = "external NLO matrix element provider"
@
<<Features: print>>=
call print_check ("Recola")
<<Features: dependencies>>=
use system_dependencies, only: RECOLA_AVAILABLE
<<Features: cases>>=
case ("recola")
if (RECOLA_AVAILABLE) then
result = "yes"
end if
help = "external NLO matrix element provider"
@
<<Features: print>>=
call print_check ("LHAPDF")
<<Features: dependencies>>=
use system_dependencies, only: LHAPDF5_AVAILABLE
use system_dependencies, only: LHAPDF6_AVAILABLE
<<Features: cases>>=
case ("lhapdf")
if (LHAPDF5_AVAILABLE) then
result = "v5"
else if (LHAPDF6_AVAILABLE) then
result = "v6"
end if
help = "PDF library"
@
<<Features: print>>=
call print_check ("HOPPET")
<<Features: dependencies>>=
use system_dependencies, only: HOPPET_AVAILABLE
<<Features: cases>>=
case ("hoppet")
if (HOPPET_AVAILABLE) then
result = "yes"
end if
help = "PDF evolution package"
@
<<Features: print>>=
call print_check ("fastjet")
<<Features: dependencies>>=
use jets, only: fastjet_available
<<Features: cases>>=
case ("fastjet")
if (fastjet_available ()) then
result = "yes"
end if
help = "jet-clustering package"
@
<<Features: print>>=
call print_check ("Pythia6")
<<Features: dependencies>>=
use system_dependencies, only: PYTHIA6_AVAILABLE
<<Features: cases>>=
case ("pythia6")
if (PYTHIA6_AVAILABLE) then
result = "yes"
end if
help = "direct access for shower/hadronization"
@
<<Features: print>>=
call print_check ("Pythia8")
<<Features: dependencies>>=
use system_dependencies, only: PYTHIA8_AVAILABLE
<<Features: cases>>=
case ("pythia8")
if (PYTHIA8_AVAILABLE) then
result = "yes"
end if
help = "direct access for shower/hadronization"
@
<<Features: print>>=
call print_check ("StdHEP")
<<Features: cases>>=
case ("stdhep")
result = "yes"
help = "event I/O format"
@
<<Features: print>>=
call print_check ("HepMC")
<<Features: dependencies>>=
use hepmc_interface, only: hepmc_is_available
<<Features: cases>>=
case ("hepmc")
if (hepmc_is_available ()) then
result = "yes"
end if
help = "event I/O format"
@
<<Features: print>>=
call print_check ("LCIO")
<<Features: dependencies>>=
use lcio_interface, only: lcio_is_available
<<Features: cases>>=
case ("lcio")
if (lcio_is_available ()) then
result = "yes"
end if
help = "event I/O format"
@
<<Features: print>>=
call print_check ("MetaPost")
<<Features: dependencies>>=
use system_dependencies, only: EVENT_ANALYSIS
<<Features: cases>>=
case ("metapost")
result = EVENT_ANALYSIS
help = "graphical event analysis via LaTeX/MetaPost"
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
Index: trunk/src/blha/blha.nw
===================================================================
--- trunk/src/blha/blha.nw (revision 8842)
+++ trunk/src/blha/blha.nw (revision 8843)
@@ -1,4272 +1,4272 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: matrix elements and process libraries
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{BLHA Interface}
\includemodulegraph{blha}
The code in this chapter implements support for the BLHA record that
communicates data for NLO processes.
These are the modules:
\begin{description}
\item[blha\_config]
\item[blha\_olp\_interfaces]
\end{description}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
The module is split into a configuration interface which manages configuration
and handles the request and contract files, a module which interfaces the OLP
matrix elements and a driver.
<<[[blha_config.f90]]>>=
<<File header>>
module blha_config
use kinds
<<Use strings>>
use variables, only: var_list_t
use model_data
use beam_structures, only: beam_structure_t
<<Standard module head>>
<<BLHA config: public>>
<<BLHA config: parameters>>
<<BLHA config: types>>
<<BLHA config: variables>>
<<BLHA config: interfaces>>
interface
<<BLHA config: sub interfaces>>
end interface
end module blha_config
@ %def blha_config
@
<<[[blha_config_sub.f90]]>>=
<<File header>>
submodule (blha_config) blha_config_s
<<Use mpi f08>>
use io_units
use constants
use string_utils
use physics_defs, only: PHOTON, PHOTON_OFFSHELL
use diagnostics
use flavors
use pdg_arrays
implicit none
contains
<<BLHA config: procedures>>
end submodule blha_config_s
@ %def blha_config_s
@
\section{Configuration}
Parameters to enumerate the different options in the order.
<<BLHA config: parameters>>=
integer, public, parameter :: &
BLHA_CT_QCD = 1, BLHA_CT_EW = 2, BLHA_CT_OTHER = 3
integer, public, parameter :: &
BLHA_IRREG_CDR = 1, BLHA_IRREG_DRED = 2, BLHA_IRREG_THV = 3, &
BLHA_IRREG_MREG = 4, BLHA_IRREG_OTHER = 5
integer, public, parameter :: &
BLHA_MPS_ONSHELL = 1, BLHA_MPS_OTHER = 2
integer, public, parameter :: &
BLHA_MODE_GOSAM = 1, BLHA_MODE_FEYNARTS = 2, BLHA_MODE_GENERIC = 3, &
BLHA_MODE_OPENLOOPS = 4
integer, public, parameter :: &
BLHA_VERSION_1 = 1, BLHA_VERSION_2 = 2
integer, public, parameter :: &
BLHA_AMP_LOOP = 1, BLHA_AMP_COLOR_C = 2, BLHA_AMP_SPIN_C = 3, &
BLHA_AMP_TREE = 4, BLHA_AMP_LOOPINDUCED = 5
integer, public, parameter :: &
BLHA_EW_INTERNAL = 0, &
BLHA_EW_GF = 1, BLHA_EW_MZ = 2, BLHA_EW_MSBAR = 3, &
BLHA_EW_0 = 4, BLHA_EW_RUN = 5
integer, public, parameter :: &
BLHA_WIDTH_COMPLEX = 1, BLHA_WIDTH_FIXED = 2, &
BLHA_WIDTH_RUNNING = 3, BLHA_WIDTH_POLE = 4, &
BLHA_WIDTH_DEFAULT = 5
@ %def blha_ct_qcd blha_ct_ew blha_ct_other
@ %def blha_irreg_cdr blha_irreg_dred blha_irreg_thv blha_irreg_mreg blha_irreg_other
@ %def blha_mps_onshell blha_mps_other
@ %def blha_mode_gosam blha_mode_feynarts blha_mode_generic
@ %def blha version blha_amp blha_ew blha_width
@
Those are the default pdg codes for massive particles in BLHA programs
<<BLHA config: parameters>>=
integer, parameter, public :: OLP_N_MASSIVE_PARTICLES = 12
integer, dimension(OLP_N_MASSIVE_PARTICLES), public :: &
OLP_MASSIVE_PARTICLES = [5, -5, 6, -6, 13, -13, 15, -15, 23, 24, -24, 25]
integer, parameter :: OLP_HEL_UNPOLARIZED = 0
@ %def OLP_MASSIVE_PARTICLES
@ The user might provide an extra command string for OpenLoops to
apply special libraries instead of the default ones, such as
signal-only amplitudes for off-shell top production. We check in this
subroutine that the provided string is valid and print out the
possible options to ease the user's memory.
<<BLHA config: parameters>>=
integer, parameter :: N_KNOWN_SPECIAL_OL_METHODS = 3
<<BLHA config: procedures>>=
subroutine check_extra_cmd (extra_cmd)
type(string_t), intent(in) :: extra_cmd
type(string_t), dimension(N_KNOWN_SPECIAL_OL_METHODS) :: known_methods
integer :: i
logical :: found
known_methods(1) = 'top'
known_methods(2) = 'not'
known_methods(3) = 'stop'
if (extra_cmd == var_str ("")) return
found = .false.
do i = 1, N_KNOWN_SPECIAL_OL_METHODS
found = found .or. &
(extra_cmd == var_str ('extra approx ') // known_methods(i))
end do
if (.not. found) &
call msg_fatal ("The given extra OpenLoops method is not kown ", &
[var_str ("Available commands are: "), &
var_str ("extra approx top (only WbWb signal),"), &
var_str ("extra approx stop (only WbWb singletop),"), &
var_str ("extra approx not (no top in WbWb).")])
end subroutine check_extra_cmd
@ %def check_extra_cmd
@ This type contains the pdg code of the particle to be written in the process
specification string and an optional additional information about the polarization
of the particles. Note that the output can only be processed by OpenLoops.
<<BLHA config: types>>=
type :: blha_particle_string_element_t
integer :: pdg = 0
integer :: hel = OLP_HEL_UNPOLARIZED
logical :: polarized = .false.
contains
<<BLHA config: blha particle string element: TBP>>
end type blha_particle_string_element_t
@ %def blha_particle_string_element_t
@
<<BLHA config: blha particle string element: TBP>>=
generic :: init => init_default
generic :: init => init_polarized
procedure :: init_default => blha_particle_string_element_init_default
procedure :: init_polarized => blha_particle_string_element_init_polarized
<<BLHA config: sub interfaces>>=
module subroutine blha_particle_string_element_init_default (blha_p, id)
class(blha_particle_string_element_t), intent(out) :: blha_p
integer, intent(in) :: id
end subroutine blha_particle_string_element_init_default
module subroutine blha_particle_string_element_init_polarized (blha_p, id, hel)
class(blha_particle_string_element_t), intent(out) :: blha_p
integer, intent(in) :: id, hel
end subroutine blha_particle_string_element_init_polarized
<<BLHA config: procedures>>=
module subroutine blha_particle_string_element_init_default (blha_p, id)
class(blha_particle_string_element_t), intent(out) :: blha_p
integer, intent(in) :: id
blha_p%pdg = id
end subroutine blha_particle_string_element_init_default
@ %def blha_particle_string_element_init_default
@
<<BLHA config: procedures>>=
module subroutine blha_particle_string_element_init_polarized (blha_p, id, hel)
class(blha_particle_string_element_t), intent(out) :: blha_p
integer, intent(in) :: id, hel
blha_p%polarized = .true.
blha_p%pdg = id
blha_p%hel = hel
end subroutine blha_particle_string_element_init_polarized
@ %def blha_particle_string_element_init_polarized
@
<<BLHA config: blha particle string element: TBP>>=
generic :: write_pdg => write_pdg_unit
generic :: write_pdg => write_pdg_character
procedure :: write_pdg_unit => blha_particle_string_element_write_pdg_unit
procedure :: write_pdg_character &
=> blha_particle_string_element_write_pdg_character
<<BLHA config: sub interfaces>>=
module subroutine blha_particle_string_element_write_pdg_unit (blha_p, unit)
class(blha_particle_string_element_t), intent(in) :: blha_p
integer, intent(in), optional :: unit
end subroutine blha_particle_string_element_write_pdg_unit
module subroutine blha_particle_string_element_write_pdg_character (blha_p, c)
class(blha_particle_string_element_t), intent(in) :: blha_p
character(3), intent(inout) :: c
end subroutine blha_particle_string_element_write_pdg_character
<<BLHA config: procedures>>=
module subroutine blha_particle_string_element_write_pdg_unit (blha_p, unit)
class(blha_particle_string_element_t), intent(in) :: blha_p
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, '(I3)') blha_p%pdg
end subroutine blha_particle_string_element_write_pdg_unit
@ %def blha_particle_string_element_write_pdg_unit
@
<<BLHA config: procedures>>=
module subroutine blha_particle_string_element_write_pdg_character (blha_p, c)
class(blha_particle_string_element_t), intent(in) :: blha_p
character(3), intent(inout) :: c
write (c, '(I3)') blha_p%pdg
end subroutine blha_particle_string_element_write_pdg_character
@ %def blha_particle_string_element_write_pdg_character
@
<<BLHA config: blha particle string element: TBP>>=
generic :: write_helicity => write_helicity_unit
generic :: write_helicity => write_helicity_character
procedure :: write_helicity_unit &
=> blha_particle_string_element_write_helicity_unit
procedure :: write_helicity_character &
=> blha_particle_string_element_write_helicity_character
<<BLHA config: sub interfaces>>=
module subroutine blha_particle_string_element_write_helicity_unit (blha_p, unit)
class(blha_particle_string_element_t), intent(in) :: blha_p
integer, intent(in), optional :: unit
end subroutine blha_particle_string_element_write_helicity_unit
module subroutine blha_particle_string_element_write_helicity_character (blha_p, c)
class(blha_particle_string_element_t), intent(in) :: blha_p
character(4), intent(inout) :: c
end subroutine blha_particle_string_element_write_helicity_character
<<BLHA config: procedures>>=
module subroutine blha_particle_string_element_write_helicity_unit (blha_p, unit)
class(blha_particle_string_element_t), intent(in) :: blha_p
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, '(A1,I0,A1)') '(', blha_p%hel, ')'
end subroutine blha_particle_string_element_write_helicity_unit
@ %def blha_particle_string_element_write_helicity_unit
@
<<BLHA config: procedures>>=
module subroutine blha_particle_string_element_write_helicity_character (blha_p, c)
class(blha_particle_string_element_t), intent(in) :: blha_p
character(4), intent(inout) :: c
write (c, '(A1,I0,A1)') '(', blha_p%hel, ')'
end subroutine blha_particle_string_element_write_helicity_character
@ %def blha_particle_string_element_write_helicity_character
@ This type encapsulates a BLHA request.
<<BLHA config: public>>=
public :: blha_configuration_t
public :: blha_cfg_process_node_t
<<BLHA config: types>>=
type :: blha_cfg_process_node_t
type(blha_particle_string_element_t), dimension(:), allocatable :: pdg_in, pdg_out
integer, dimension(:), allocatable :: fingerprint
integer :: nsub
integer, dimension(:), allocatable :: ids
integer :: amplitude_type
type(blha_cfg_process_node_t), pointer :: next => null ()
end type blha_cfg_process_node_t
type :: blha_configuration_t
type(string_t) :: name
class(model_data_t), pointer :: model => null ()
type(string_t) :: md5
integer :: version = 2
logical :: dirty = .false.
integer :: n_proc = 0
real(default) :: accuracy_target
logical :: debug_unstable = .false.
integer :: mode = BLHA_MODE_GENERIC
logical :: polarized = .false.
type(blha_cfg_process_node_t), pointer :: processes => null ()
!integer, dimension(2) :: matrix_element_square_type = BLHA_MEST_SUM
integer :: correction_type
type(string_t) :: correction_type_other
integer :: irreg = BLHA_IRREG_THV
type(string_t) :: irreg_other
integer :: massive_particle_scheme = BLHA_MPS_ONSHELL
type(string_t) :: massive_particle_scheme_other
type(string_t) :: model_file
logical :: subdivide_subprocesses = .false.
integer :: alphas_power = -1, alpha_power = -1
integer :: ew_scheme = BLHA_EW_GF
integer :: width_scheme = BLHA_WIDTH_DEFAULT
logical :: openloops_use_cms = .false.
integer :: openloops_phs_tolerance = 0
type(string_t) :: openloops_extra_cmd
type(string_t) :: openloops_allowed_libs
integer :: openloops_stability_log = 0
integer :: n_off_photons_is = 0
integer :: n_off_photons_fs = 0
end type blha_configuration_t
@ %def blha_cffg_process_node_t blha_configuration_t
@ Translate the SINDARIN input string to the corresponding named integer.
<<BLHA config: public>>=
public :: ew_scheme_string_to_int
<<BLHA config: sub interfaces>>=
module function ew_scheme_string_to_int (ew_scheme_str) result (ew_scheme_int)
integer :: ew_scheme_int
type(string_t), intent(in) :: ew_scheme_str
end function ew_scheme_string_to_int
<<BLHA config: procedures>>=
module function ew_scheme_string_to_int (ew_scheme_str) result (ew_scheme_int)
integer :: ew_scheme_int
type(string_t), intent(in) :: ew_scheme_str
select case (char (ew_scheme_str))
case ('GF', 'Gmu')
ew_scheme_int = BLHA_EW_GF
case ('alpha_qed', 'alpha_internal')
ew_scheme_int = BLHA_EW_INTERNAL
case ('alpha_mz')
ew_scheme_int = BLHA_EW_MZ
case ('alpha_0', 'alpha_thompson')
ew_scheme_int = BLHA_EW_0
case default
call msg_fatal ("ew_scheme: " // char (ew_scheme_str) // &
" not supported. Try 'Gmu', 'alpha_internal', 'alpha_mz' or 'alpha_0'.")
end select
end function ew_scheme_string_to_int
@ %def ew_scheme_string_to_int
@
@ Translate the SINDARIN input string to the corresponding named integer
denoting the type of NLO correction.
<<BLHA config: public>>=
public :: correction_type_string_to_int
<<BLHA config: sub interfaces>>=
module function correction_type_string_to_int &
(correction_type_str) result (correction_type_int)
integer :: correction_type_int
type(string_t), intent(in) :: correction_type_str
end function correction_type_string_to_int
<<BLHA config: procedures>>=
module function correction_type_string_to_int &
(correction_type_str) result (correction_type_int)
integer :: correction_type_int
type(string_t), intent(in) :: correction_type_str
select case (char (correction_type_str))
case ('QCD')
correction_type_int = BLHA_CT_QCD
case ('EW')
correction_type_int = BLHA_CT_EW
case default
call msg_warning ("nlo_correction_type: " // char (correction_type_str) // &
" not supported. Try setting it to 'QCD', 'EW'.")
end select
end function correction_type_string_to_int
@ %def correction_type_string_to_int
@
This types control the creation of BLHA-interface files
<<BLHA config: public>>=
public :: blha_flv_state_t
public :: blha_master_t
<<BLHA config: types>>=
type:: blha_flv_state_t
integer, dimension(:), allocatable :: flavors
integer :: flv_mult
logical :: flv_real = .false.
end type blha_flv_state_t
type :: blha_master_t
integer, dimension(5) :: blha_mode = BLHA_MODE_GENERIC
logical :: compute_borns = .false.
logical :: compute_real_trees = .false.
logical :: compute_loops = .true.
logical :: compute_correlations = .false.
logical :: compute_dglap = .false.
integer :: ew_scheme
type(string_t), dimension(:), allocatable :: suffix
type(blha_configuration_t), dimension(:), allocatable :: blha_cfg
integer :: n_files = 0
integer, dimension(:), allocatable :: i_file_to_nlo_index
contains
<<BLHA config: blha master: TBP>>
end type blha_master_t
@ %def blha_flv_state_t, blha_master_t
@ Master-Routines
<<BLHA config: blha master: TBP>>=
procedure :: set_methods => blha_master_set_methods
<<BLHA config: sub interfaces>>=
module subroutine blha_master_set_methods (master, is_nlo, var_list)
class(blha_master_t), intent(inout) :: master
logical, intent(in) :: is_nlo
type(var_list_t), intent(in) :: var_list
end subroutine blha_master_set_methods
<<BLHA config: procedures>>=
module subroutine blha_master_set_methods (master, is_nlo, var_list)
class(blha_master_t), intent(inout) :: master
logical, intent(in) :: is_nlo
type(var_list_t), intent(in) :: var_list
type(string_t) :: method, born_me_method, real_tree_me_method
type(string_t) :: loop_me_method, correlation_me_method
type(string_t) :: dglap_me_method
type(string_t) :: default_method
logical :: cmp_born, cmp_real
logical :: cmp_loop, cmp_corr
logical :: cmp_dglap
if (is_nlo) then
method = var_list%get_sval (var_str ("$method"))
born_me_method = var_list%get_sval (var_str ("$born_me_method"))
if (born_me_method == "") born_me_method = method
real_tree_me_method = var_list%get_sval (var_str ("$real_tree_me_method"))
if (real_tree_me_method == "") real_tree_me_method = method
loop_me_method = var_list%get_sval (var_str ("$loop_me_method"))
if (loop_me_method == "") loop_me_method = method
correlation_me_method = var_list%get_sval (var_str ("$correlation_me_method"))
if (correlation_me_method == "") correlation_me_method = method
dglap_me_method = var_list%get_sval (var_str ("$dglap_me_method"))
if (dglap_me_method == "") dglap_me_method = method
cmp_born = born_me_method /= 'omega'
cmp_real = is_nlo .and. (real_tree_me_method /= 'omega')
cmp_loop = is_nlo .and. (loop_me_method /= 'omega')
cmp_corr = is_nlo .and. (correlation_me_method /= 'omega')
cmp_dglap = is_nlo .and. (dglap_me_method /= 'omega')
call set_me_method (1, loop_me_method)
call set_me_method (2, correlation_me_method)
call set_me_method (3, real_tree_me_method)
call set_me_method (4, born_me_method)
call set_me_method (5, dglap_me_method)
else
default_method = var_list%get_sval (var_str ("$method"))
cmp_born = default_method /= 'omega'
cmp_real = .false.; cmp_loop = .false.; cmp_corr = .false.
call set_me_method (4, default_method)
end if
master%n_files = count ([cmp_born, cmp_real, cmp_loop, cmp_corr, cmp_dglap])
call set_nlo_indices ()
master%compute_borns = cmp_born
master%compute_real_trees = cmp_real
master%compute_loops = cmp_loop
master%compute_correlations = cmp_corr
master%compute_dglap = cmp_dglap
contains
subroutine set_nlo_indices ()
integer :: i_file
allocate (master%i_file_to_nlo_index (master%n_files))
master%i_file_to_nlo_index = 0
i_file = 0
if (cmp_loop) then
i_file = i_file + 1
master%i_file_to_nlo_index(i_file) = 1
end if
if (cmp_corr) then
i_file = i_file + 1
master%i_file_to_nlo_index(i_file) = 2
end if
if (cmp_real) then
i_file = i_file + 1
master%i_file_to_nlo_index(i_file) = 3
end if
if (cmp_born) then
i_file = i_file + 1
master%i_file_to_nlo_index(i_file) = 4
end if
if (cmp_dglap) then
i_file = i_file + 1
master%i_file_to_nlo_index(i_file) = 5
end if
end subroutine set_nlo_indices
subroutine set_me_method (i, me_method)
integer, intent(in) :: i
type(string_t) :: me_method
select case (char (me_method))
case ('gosam')
call master%set_gosam (i)
case ('openloops')
call master%set_openloops (i)
end select
end subroutine set_me_method
end subroutine blha_master_set_methods
@ %def blha_master_set_methods
@
<<BLHA config: blha master: TBP>>=
procedure :: allocate_config_files => blha_master_allocate_config_files
<<BLHA config: sub interfaces>>=
module subroutine blha_master_allocate_config_files (master)
class(blha_master_t), intent(inout) :: master
end subroutine blha_master_allocate_config_files
<<BLHA config: procedures>>=
module subroutine blha_master_allocate_config_files (master)
class(blha_master_t), intent(inout) :: master
allocate (master%blha_cfg (master%n_files))
allocate (master%suffix (master%n_files))
end subroutine blha_master_allocate_config_files
@ %def blha_master_allocate_config_files
@
<<BLHA config: blha master: TBP>>=
procedure :: set_ew_scheme => blha_master_set_ew_scheme
<<BLHA config: sub interfaces>>=
module subroutine blha_master_set_ew_scheme (master, ew_scheme)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: ew_scheme
end subroutine blha_master_set_ew_scheme
<<BLHA config: procedures>>=
module subroutine blha_master_set_ew_scheme (master, ew_scheme)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: ew_scheme
master%ew_scheme = ew_scheme_string_to_int (ew_scheme)
end subroutine blha_master_set_ew_scheme
@ %def blha_master_set_ew_scheme
@
<<BLHA config: blha master: TBP>>=
procedure :: set_correction_type => blha_master_set_correction_type
<<BLHA config: sub interfaces>>=
module subroutine blha_master_set_correction_type (master, correction_type_str)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: correction_type_str
end subroutine blha_master_set_correction_type
<<BLHA config: procedures>>=
module subroutine blha_master_set_correction_type (master, correction_type_str)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: correction_type_str
master%blha_cfg(:)%correction_type = &
correction_type_string_to_int (correction_type_str)
end subroutine blha_master_set_correction_type
@ %def blha_master_set_correction_type
@
<<BLHA config: blha master: TBP>>=
procedure :: set_photon_characteristics => blha_master_set_photon_characteristics
<<BLHA config: sub interfaces>>=
module subroutine blha_master_set_photon_characteristics (master, flv_born, n_in)
class(blha_master_t), intent(inout) :: master
integer, dimension(:,:), intent(in) :: flv_born
integer, intent(in) :: n_in
end subroutine blha_master_set_photon_characteristics
<<BLHA config: procedures>>=
module subroutine blha_master_set_photon_characteristics (master, flv_born, n_in)
class(blha_master_t), intent(inout) :: master
integer, dimension(:,:), intent(in) :: flv_born
integer, intent(in) :: n_in
integer :: i_file, i, i_flv
integer :: noff_is, noff_fs, noff_is_max, noff_fs_max
do i_file = 1, master%n_files
noff_is_max = 0; noff_fs_max = 0
do i_flv = 1, size (flv_born, 2)
noff_is = 0; noff_fs = 0
do i = 1, n_in
if (flv_born (i, i_flv) == PHOTON) noff_is = noff_is + 1
end do
noff_is_max = max (noff_is, noff_is_max)
do i = n_in + 1, size (flv_born(:, i_flv))
if (flv_born (i, i_flv) == PHOTON) noff_fs = noff_fs + 1
end do
noff_fs_max = max (noff_fs, noff_fs_max)
end do
if (master%blha_cfg(i_file)%correction_type == BLHA_CT_EW &
.and. master%ew_scheme == BLHA_EW_0 &
.and. (noff_is_max > 0 .or. noff_fs_max > 0)) then
call msg_fatal ("For NLO EW/mixed corrections, 'alpha_0'/" &
// "'alpha_thompson' are ", [ var_str ("inconsistent EW input " &
// "schemes. Please use 'alpha_mz' or 'Gmu'")])
end if
master%blha_cfg(i_file)%n_off_photons_is = noff_is_max
master%blha_cfg(i_file)%n_off_photons_fs = noff_fs_max
end do
end subroutine blha_master_set_photon_characteristics
@ %def blha_master_set_photon_characteristics
@
<<BLHA config: blha master: TBP>>=
procedure :: generate => blha_master_generate
<<BLHA config: sub interfaces>>=
module subroutine blha_master_generate (master, basename, model, &
n_in, alpha_power, alphas_power, flv_born, flv_real)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: basename
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in
integer, intent(in) :: alpha_power, alphas_power
integer, intent(in), dimension(:,:), allocatable :: flv_born, flv_real
end subroutine blha_master_generate
<<BLHA config: procedures>>=
module subroutine blha_master_generate (master, basename, model, &
n_in, alpha_power, alphas_power, flv_born, flv_real)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: basename
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in
integer, intent(in) :: alpha_power, alphas_power
integer, intent(in), dimension(:,:), allocatable :: flv_born, flv_real
integer :: i_file
if (master%n_files < 1) &
call msg_fatal ("Attempting to generate OLP-files, but none are specified!")
i_file = 1
call master%generate_loop (basename, model, n_in, alpha_power, &
alphas_power, flv_born, i_file)
call master%generate_correlation (basename, model, n_in, alpha_power, &
alphas_power, flv_born, i_file)
call master%generate_real_tree (basename, model, n_in, alpha_power, &
alphas_power, flv_real, i_file)
call master%generate_born (basename, model, n_in, alpha_power, &
alphas_power, flv_born, i_file)
call master%generate_dglap (basename, model, n_in, alpha_power, &
alphas_power, flv_born, i_file)
end subroutine blha_master_generate
@ %def blha_master_generate
@
<<BLHA config: blha master: TBP>>=
procedure :: generate_loop => blha_master_generate_loop
<<BLHA config: sub interfaces>>=
module subroutine blha_master_generate_loop (master, basename, model, n_in, &
alpha_power, alphas_power, flv_born, i_file)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: basename
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in
integer, intent(in) :: alpha_power, alphas_power
integer, dimension(:,:), allocatable, intent(in) :: flv_born
integer, intent(inout) :: i_file
end subroutine blha_master_generate_loop
<<BLHA config: procedures>>=
module subroutine blha_master_generate_loop (master, basename, model, n_in, &
alpha_power, alphas_power, flv_born, i_file)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: basename
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in
integer, intent(in) :: alpha_power, alphas_power
integer, dimension(:,:), allocatable, intent(in) :: flv_born
integer, intent(inout) :: i_file
type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor
integer :: i_flv
if (master%compute_loops) then
if (allocated (flv_born)) then
allocate (blha_flavor (size (flv_born, 2)))
do i_flv = 1, size (flv_born, 2)
allocate (blha_flavor(i_flv)%flavors (size (flv_born(:,i_flv))))
blha_flavor(i_flv)%flavors = flv_born(:,i_flv)
blha_flavor(i_flv)%flv_mult = 2
end do
master%suffix(i_file) = blha_get_additional_suffix (var_str ("_LOOP"))
call blha_init_virtual (master%blha_cfg(i_file), blha_flavor, &
n_in, alpha_power, alphas_power, master%ew_scheme, &
basename, model, master%blha_mode(1), master%suffix(i_file))
i_file = i_file + 1
else
call msg_fatal ("BLHA Loops requested but " &
// "Born flavor not existing")
end if
end if
end subroutine blha_master_generate_loop
@ %def blha_master_generate_loop
@
<<BLHA config: blha master: TBP>>=
procedure :: generate_correlation => blha_master_generate_correlation
<<BLHA config: sub interfaces>>=
module subroutine blha_master_generate_correlation (master, basename, model, n_in, &
alpha_power, alphas_power, flv_born, i_file)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: basename
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in
integer, intent(in) :: alpha_power, alphas_power
integer, dimension(:,:), allocatable, intent(in) :: flv_born
integer, intent(inout) :: i_file
end subroutine blha_master_generate_correlation
<<BLHA config: procedures>>=
module subroutine blha_master_generate_correlation (master, basename, model, n_in, &
alpha_power, alphas_power, flv_born, i_file)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: basename
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in
integer, intent(in) :: alpha_power, alphas_power
integer, dimension(:,:), allocatable, intent(in) :: flv_born
integer, intent(inout) :: i_file
type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor
integer :: i_flv
if (master%compute_correlations) then
if (allocated (flv_born)) then
allocate (blha_flavor (size (flv_born, 2)))
do i_flv = 1, size (flv_born, 2)
allocate (blha_flavor(i_flv)%flavors (size (flv_born(:,i_flv))))
blha_flavor(i_flv)%flavors = flv_born(:,i_flv)
blha_flavor(i_flv)%flv_mult = 3
end do
master%suffix(i_file) = blha_get_additional_suffix (var_str ("_SUB"))
call blha_init_subtraction (master%blha_cfg(i_file), blha_flavor, &
n_in, alpha_power, alphas_power, master%ew_scheme, &
basename, model, master%blha_mode(2), master%suffix(i_file))
i_file = i_file + 1
else
call msg_fatal ("BLHA Correlations requested but "&
// "Born flavor not existing")
end if
end if
end subroutine blha_master_generate_correlation
@ %def blha_master_generate_correlation
@
<<BLHA config: blha master: TBP>>=
procedure :: generate_real_tree => blha_master_generate_real_tree
<<BLHA config: sub interfaces>>=
module subroutine blha_master_generate_real_tree (master, basename, model, n_in, &
alpha_power, alphas_power, flv_real, i_file)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: basename
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in
integer, intent(in) :: alpha_power, alphas_power
integer, dimension(:,:), allocatable, intent(in) :: flv_real
integer, intent(inout) :: i_file
end subroutine blha_master_generate_real_tree
<<BLHA config: procedures>>=
module subroutine blha_master_generate_real_tree (master, basename, model, n_in, &
alpha_power, alphas_power, flv_real, i_file)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: basename
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in
integer, intent(in) :: alpha_power, alphas_power
integer, dimension(:,:), allocatable, intent(in) :: flv_real
integer, intent(inout) :: i_file
type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor
integer :: i_flv
if (master%compute_real_trees) then
if (allocated (flv_real)) then
allocate (blha_flavor (size (flv_real, 2)))
do i_flv = 1, size (flv_real, 2)
allocate (blha_flavor(i_flv)%flavors (size (flv_real(:,i_flv))))
blha_flavor(i_flv)%flavors = flv_real(:,i_flv)
blha_flavor(i_flv)%flv_mult = 1
end do
master%suffix(i_file) = blha_get_additional_suffix (var_str ("_REAL"))
call blha_init_real (master%blha_cfg(i_file), blha_flavor, &
n_in, alpha_power, alphas_power, master%ew_scheme, &
basename, model, master%blha_mode(3), master%suffix(i_file))
i_file = i_file + 1
else
call msg_fatal ("BLHA Trees requested but "&
// "Real flavor not existing")
end if
end if
end subroutine blha_master_generate_real_tree
@ %def blha_master_generate_real_tree
@
<<BLHA config: blha master: TBP>>=
procedure :: generate_born => blha_master_generate_born
<<BLHA config: sub interfaces>>=
module subroutine blha_master_generate_born (master, basename, model, n_in, &
alpha_power, alphas_power, flv_born, i_file)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: basename
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in
integer, intent(in) :: alpha_power, alphas_power
integer, dimension(:,:), allocatable, intent(in) :: flv_born
integer, intent(inout) :: i_file
end subroutine blha_master_generate_born
<<BLHA config: procedures>>=
module subroutine blha_master_generate_born (master, basename, model, n_in, &
alpha_power, alphas_power, flv_born, i_file)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: basename
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in
integer, intent(in) :: alpha_power, alphas_power
integer, dimension(:,:), allocatable, intent(in) :: flv_born
integer, intent(inout) :: i_file
type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor
integer :: i_flv
if (master%compute_borns) then
if (allocated (flv_born)) then
allocate (blha_flavor (size (flv_born, 2)))
do i_flv = 1, size (flv_born, 2)
allocate (blha_flavor(i_flv)%flavors (size (flv_born(:,i_flv))))
blha_flavor(i_flv)%flavors = flv_born(:,i_flv)
blha_flavor(i_flv)%flv_mult = 1
end do
master%suffix(i_file) = blha_get_additional_suffix (var_str ("_BORN"))
call blha_init_born (master%blha_cfg(i_file), blha_flavor, &
n_in, alpha_power, alphas_power, master%ew_scheme, &
basename, model, master%blha_mode(4), master%suffix(i_file))
i_file = i_file + 1
end if
end if
end subroutine blha_master_generate_born
@ %def blha_master_generate_born
@
<<BLHA config: blha master: TBP>>=
procedure :: generate_dglap => blha_master_generate_dglap
<<BLHA config: sub interfaces>>=
module subroutine blha_master_generate_dglap (master, basename, model, n_in, &
alpha_power, alphas_power, flv_born, i_file)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: basename
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in
integer, intent(in) :: alpha_power, alphas_power
integer, dimension(:,:), allocatable, intent(in) :: flv_born
integer, intent(inout) :: i_file
end subroutine blha_master_generate_dglap
<<BLHA config: procedures>>=
module subroutine blha_master_generate_dglap (master, basename, model, n_in, &
alpha_power, alphas_power, flv_born, i_file)
class(blha_master_t), intent(inout) :: master
type(string_t), intent(in) :: basename
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in
integer, intent(in) :: alpha_power, alphas_power
integer, dimension(:,:), allocatable, intent(in) :: flv_born
integer, intent(inout) :: i_file
type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor
integer :: i_flv
if (master%compute_dglap) then
if (allocated (flv_born)) then
allocate (blha_flavor (size (flv_born, 2)))
do i_flv = 1, size (flv_born, 2)
allocate (blha_flavor(i_flv)%flavors (size (flv_born(:,i_flv))))
blha_flavor(i_flv)%flavors = flv_born(:,i_flv)
blha_flavor(i_flv)%flv_mult = 2
end do
master%suffix(i_file) = blha_get_additional_suffix (var_str ("_DGLAP"))
call blha_init_dglap (master%blha_cfg(i_file), blha_flavor, &
n_in, alpha_power, alphas_power, master%ew_scheme, &
basename, model, master%blha_mode(5), master%suffix(i_file))
i_file = i_file + 1
end if
end if
end subroutine blha_master_generate_dglap
@ %def blha_master_generate_dglap
@
<<BLHA config: blha master: TBP>>=
procedure :: setup_additional_features => blha_master_setup_additional_features
<<BLHA config: sub interfaces>>=
module subroutine blha_master_setup_additional_features (master, &
phs_tolerance, use_cms, stability_log, extra_cmd, &
allowed_libs, beam_structure)
class(blha_master_t), intent(inout) :: master
integer, intent(in) :: phs_tolerance
logical, intent(in) :: use_cms
type(string_t), intent(in), optional :: extra_cmd, allowed_libs
integer, intent(in) :: stability_log
type(beam_structure_t), intent(in), optional :: beam_structure
end subroutine blha_master_setup_additional_features
<<BLHA config: procedures>>=
module subroutine blha_master_setup_additional_features (master, &
phs_tolerance, use_cms, stability_log, extra_cmd, &
allowed_libs,beam_structure)
class(blha_master_t), intent(inout) :: master
integer, intent(in) :: phs_tolerance
logical, intent(in) :: use_cms
type(string_t), intent(in), optional :: extra_cmd, allowed_libs
integer, intent(in) :: stability_log
type(beam_structure_t), intent(in), optional :: beam_structure
integer :: i_file
logical :: polarized, throw_warning
polarized = .false.
if (present (beam_structure)) polarized = beam_structure%has_polarized_beams ()
throw_warning = .false.
if (use_cms) then
throw_warning = throw_warning .or. (master%compute_loops &
.and. master%blha_mode(1) /= BLHA_MODE_OPENLOOPS)
throw_warning = throw_warning .or. (master%compute_correlations &
.and. master%blha_mode(2) /= BLHA_MODE_OPENLOOPS)
throw_warning = throw_warning .or. (master%compute_real_trees &
.and. master%blha_mode(3) /= BLHA_MODE_OPENLOOPS)
throw_warning = throw_warning .or. (master%compute_borns &
.and. master%blha_mode(4) /= BLHA_MODE_OPENLOOPS)
throw_warning = throw_warning .or. (master%compute_dglap &
.and. master%blha_mode(5) /= BLHA_MODE_OPENLOOPS)
if (throw_warning) call cms_warning ()
end if
do i_file = 1, master%n_files
if (phs_tolerance > 0) then
select case (master%blha_mode (master%i_file_to_nlo_index(i_file)))
case (BLHA_MODE_GOSAM)
if (polarized) call gosam_error_message ()
case (BLHA_MODE_OPENLOOPS)
master%blha_cfg(i_file)%openloops_use_cms = use_cms
master%blha_cfg(i_file)%openloops_phs_tolerance = phs_tolerance
master%blha_cfg(i_file)%polarized = polarized
if (present (extra_cmd)) then
master%blha_cfg(i_file)%openloops_extra_cmd = extra_cmd
else
master%blha_cfg(i_file)%openloops_extra_cmd = var_str ('')
end if
if (present (extra_cmd)) then
master%blha_cfg(i_file)%openloops_allowed_libs = allowed_libs
else
master%blha_cfg(i_file)%openloops_allowed_libs = var_str ('')
end if
master%blha_cfg(i_file)%openloops_stability_log = stability_log
end select
end if
end do
contains
subroutine cms_warning ()
call msg_warning ("You have set ?openloops_use_cms = true, but not all active matrix ", &
[var_str ("element methods are set to OpenLoops. Note that other "), &
var_str ("methods might not necessarily support the complex mass "), &
var_str ("scheme. This can yield inconsistencies in your NLO results!")])
end subroutine cms_warning
subroutine gosam_error_message ()
call msg_fatal ("You are trying to evaluate a process at NLO ", &
[var_str ("which involves polarized beams using GoSam. "), &
var_str ("This feature is not supported yet. "), &
var_str ("Please use OpenLoops instead")])
end subroutine gosam_error_message
end subroutine blha_master_setup_additional_features
@ %def blha_master_setup_additional_features
@
<<BLHA config: blha master: TBP>>=
procedure :: set_gosam => blha_master_set_gosam
<<BLHA config: sub interfaces>>=
module subroutine blha_master_set_gosam (master, i)
class(blha_master_t), intent(inout) :: master
integer, intent(in) :: i
end subroutine blha_master_set_gosam
<<BLHA config: procedures>>=
module subroutine blha_master_set_gosam (master, i)
class(blha_master_t), intent(inout) :: master
integer, intent(in) :: i
master%blha_mode(i) = BLHA_MODE_GOSAM
end subroutine blha_master_set_gosam
@ %def blha_master_set_gosam
@
<<BLHA config: blha master: TBP>>=
procedure :: set_openloops => blha_master_set_openloops
<<BLHA config: sub interfaces>>=
module subroutine blha_master_set_openloops (master, i)
class(blha_master_t), intent(inout) :: master
integer, intent(in) :: i
end subroutine blha_master_set_openloops
<<BLHA config: procedures>>=
module subroutine blha_master_set_openloops (master, i)
class(blha_master_t), intent(inout) :: master
integer, intent(in) :: i
master%blha_mode(i) = BLHA_MODE_OPENLOOPS
end subroutine blha_master_set_openloops
@ %def blha_master_set_openloops
@
<<BLHA config: blha master: TBP>>=
procedure :: set_polarization => blha_master_set_polarization
<<BLHA config: sub interfaces>>=
module subroutine blha_master_set_polarization (master, i)
class(blha_master_t), intent(inout) :: master
integer, intent(in) :: i
end subroutine blha_master_set_polarization
<<BLHA config: procedures>>=
module subroutine blha_master_set_polarization (master, i)
class(blha_master_t), intent(inout) :: master
integer, intent(in) :: i
master%blha_cfg(i)%polarized = .true.
end subroutine blha_master_set_polarization
@ %def blha_master_set_polarization
@
<<BLHA config: procedures>>=
subroutine blha_init_born (blha_cfg, blha_flavor, n_in, &
ap, asp, ew_scheme, basename, model, blha_mode, suffix)
type(blha_configuration_t), intent(inout) :: blha_cfg
type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor
integer, intent(in) :: n_in
integer, intent(in) :: ap, asp
integer, intent(in) :: ew_scheme
type(string_t), intent(in) :: basename
type(model_data_t), intent(in), target :: model
integer, intent(in) :: blha_mode
type(string_t), intent(in) :: suffix
integer, dimension(:), allocatable :: amp_type
integer :: i
allocate (amp_type (size (blha_flavor)))
do i = 1, size (blha_flavor)
amp_type(i) = BLHA_AMP_TREE
end do
call blha_configuration_init (blha_cfg, basename // suffix , &
model, blha_mode)
call blha_configuration_append_processes (blha_cfg, n_in, &
blha_flavor, amp_type)
call blha_configuration_set (blha_cfg, BLHA_VERSION_2, &
irreg = BLHA_IRREG_CDR, alphas_power = asp, &
alpha_power = ap, ew_scheme = ew_scheme, &
debug = blha_mode == BLHA_MODE_GOSAM)
end subroutine blha_init_born
subroutine blha_init_virtual (blha_cfg, blha_flavor, n_in, &
ap, asp, ew_scheme, basename, model, blha_mode, suffix)
type(blha_configuration_t), intent(inout) :: blha_cfg
type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor
integer, intent(in) :: n_in
integer, intent(in) :: ap, asp
integer, intent(in) :: ew_scheme
type(string_t), intent(in) :: basename
type(model_data_t), intent(in), target :: model
integer, intent(in) :: blha_mode
type(string_t), intent(in) :: suffix
integer, dimension(:), allocatable :: amp_type
integer :: i
allocate (amp_type (size (blha_flavor) * 2))
do i = 1, size (blha_flavor)
amp_type(2 * i - 1) = BLHA_AMP_LOOP
amp_type(2 * i) = BLHA_AMP_COLOR_C
end do
call blha_configuration_init (blha_cfg, basename // suffix , &
model, blha_mode)
call blha_configuration_append_processes (blha_cfg, n_in, &
blha_flavor, amp_type)
call blha_configuration_set (blha_cfg, BLHA_VERSION_2, &
irreg = BLHA_IRREG_CDR, &
alphas_power = asp, &
alpha_power = ap, &
ew_scheme = ew_scheme, &
debug = blha_mode == BLHA_MODE_GOSAM)
end subroutine blha_init_virtual
subroutine blha_init_dglap (blha_cfg, blha_flavor, n_in, &
ap, asp, ew_scheme, basename, model, blha_mode, suffix)
type(blha_configuration_t), intent(inout) :: blha_cfg
type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor
integer, intent(in) :: n_in
integer, intent(in) :: ap, asp
integer, intent(in) :: ew_scheme
type(string_t), intent(in) :: basename
type(model_data_t), intent(in), target :: model
integer, intent(in) :: blha_mode
type(string_t), intent(in) :: suffix
integer, dimension(:), allocatable :: amp_type
integer :: i
allocate (amp_type (size (blha_flavor) * 2))
do i = 1, size (blha_flavor)
amp_type(2 * i - 1) = BLHA_AMP_TREE
amp_type(2 * i) = BLHA_AMP_COLOR_C
end do
call blha_configuration_init (blha_cfg, basename // suffix , &
model, blha_mode)
call blha_configuration_append_processes (blha_cfg, n_in, &
blha_flavor, amp_type)
call blha_configuration_set (blha_cfg, BLHA_VERSION_2, &
irreg = BLHA_IRREG_CDR, &
alphas_power = asp, &
alpha_power = ap, &
ew_scheme = ew_scheme, &
debug = blha_mode == BLHA_MODE_GOSAM)
end subroutine blha_init_dglap
subroutine blha_init_subtraction (blha_cfg, blha_flavor, n_in, &
ap, asp, ew_scheme, basename, model, blha_mode, suffix)
type(blha_configuration_t), intent(inout) :: blha_cfg
type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor
integer, intent(in) :: n_in
integer, intent(in) :: ap, asp
integer, intent(in) :: ew_scheme
type(string_t), intent(in) :: basename
type(model_data_t), intent(in), target :: model
integer, intent(in) :: blha_mode
type(string_t), intent(in) :: suffix
integer, dimension(:), allocatable :: amp_type
integer :: i
allocate (amp_type (size (blha_flavor) * 3))
do i = 1, size (blha_flavor)
amp_type(3 * i - 2) = BLHA_AMP_TREE
amp_type(3 * i - 1) = BLHA_AMP_COLOR_C
amp_type(3 * i) = BLHA_AMP_SPIN_C
end do
call blha_configuration_init (blha_cfg, basename // suffix , &
model, blha_mode)
call blha_configuration_append_processes (blha_cfg, n_in, &
blha_flavor, amp_type)
call blha_configuration_set (blha_cfg, BLHA_VERSION_2, &
irreg = BLHA_IRREG_CDR, &
alphas_power = asp, &
alpha_power = ap, &
ew_scheme = ew_scheme, &
debug = blha_mode == BLHA_MODE_GOSAM)
end subroutine blha_init_subtraction
subroutine blha_init_real (blha_cfg, blha_flavor, n_in, &
ap, asp, ew_scheme, basename, model, blha_mode, suffix)
type(blha_configuration_t), intent(inout) :: blha_cfg
type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor
integer, intent(in) :: n_in
integer, intent(in) :: ap, asp
integer :: ap_ew, ap_qcd
integer, intent(in) :: ew_scheme
type(string_t), intent(in) :: basename
type(model_data_t), intent(in), target :: model
integer, intent(in) :: blha_mode
type(string_t), intent(in) :: suffix
integer, dimension(:), allocatable :: amp_type
integer :: i
allocate (amp_type (size (blha_flavor)))
do i = 1, size (blha_flavor)
amp_type(i) = BLHA_AMP_TREE
end do
select case (blha_cfg%correction_type)
case (BLHA_CT_QCD)
ap_ew = ap
ap_qcd = asp + 1
case (BLHA_CT_EW)
ap_ew = ap + 1
ap_qcd = asp
end select
call blha_configuration_init (blha_cfg, basename // suffix , &
model, blha_mode)
call blha_configuration_append_processes (blha_cfg, n_in, &
blha_flavor, amp_type)
call blha_configuration_set (blha_cfg, BLHA_VERSION_2, &
irreg = BLHA_IRREG_CDR, &
alphas_power = ap_qcd, &
alpha_power = ap_ew, &
ew_scheme = ew_scheme, &
debug = blha_mode == BLHA_MODE_GOSAM)
end subroutine blha_init_real
@ %def blha_init_virtual blha_init_real
@ %def blha_init_subtraction
@
<<BLHA config: public>>=
public :: blha_get_additional_suffix
<<BLHA config: sub interfaces>>=
module function blha_get_additional_suffix (base_suffix) result (suffix)
type(string_t) :: suffix
type(string_t), intent(in) :: base_suffix
end function blha_get_additional_suffix
<<BLHA config: procedures>>=
module function blha_get_additional_suffix (base_suffix) result (suffix)
type(string_t) :: suffix
type(string_t), intent(in) :: base_suffix
<<blha master: blha master extend suffixes: variables>>
suffix = base_suffix
<<blha master: blha master extend suffixes: procedure>>
end function blha_get_additional_suffix
@ %def blha_master_extend_suffixes
@
<<MPI: blha master: blha master extend suffixes: variables>>=
integer :: n_size, rank
<<MPI: blha master: blha master extend suffixes: procedure>>=
call MPI_Comm_rank (MPI_COMM_WORLD, rank)
call MPI_Comm_size (MPI_COMM_WORLD, n_size)
if (n_size > 1) then
suffix = suffix // var_str ("_") // str (rank)
end if
@
<<BLHA config: blha master: TBP>>=
procedure :: write_olp => blha_master_write_olp
<<BLHA config: sub interfaces>>=
module subroutine blha_master_write_olp (master, basename)
class(blha_master_t), intent(in) :: master
type(string_t), intent(in) :: basename
end subroutine blha_master_write_olp
<<BLHA config: procedures>>=
module subroutine blha_master_write_olp (master, basename)
class(blha_master_t), intent(in) :: master
type(string_t), intent(in) :: basename
integer :: unit
type(string_t) :: filename
integer :: i_file
do i_file = 1, master%n_files
filename = basename // master%suffix(i_file) // ".olp"
unit = free_unit ()
open (unit, file = char (filename), status = 'replace', action = 'write')
call blha_configuration_write &
(master%blha_cfg(i_file), master%suffix(i_file), unit)
close (unit)
end do
end subroutine blha_master_write_olp
@ %def blha_master_write_olp
@
<<BLHA config: blha master: TBP>>=
procedure :: final => blha_master_final
<<BLHA config: sub interfaces>>=
module subroutine blha_master_final (master)
class(blha_master_t), intent(inout) :: master
end subroutine blha_master_final
<<BLHA config: procedures>>=
module subroutine blha_master_final (master)
class(blha_master_t), intent(inout) :: master
master%n_files = 0
deallocate (master%suffix)
deallocate (master%blha_cfg)
deallocate (master%i_file_to_nlo_index)
end subroutine blha_master_final
@ %def blha_master_final
@
<<BLHA config: public>>=
public :: blha_configuration_init
<<BLHA config: sub interfaces>>=
module subroutine blha_configuration_init (cfg, name, model, mode)
type(blha_configuration_t), intent(inout) :: cfg
type(string_t), intent(in) :: name
class(model_data_t), target, intent(in) :: model
integer, intent(in), optional :: mode
end subroutine blha_configuration_init
<<BLHA config: procedures>>=
module subroutine blha_configuration_init (cfg, name, model, mode)
type(blha_configuration_t), intent(inout) :: cfg
type(string_t), intent(in) :: name
class(model_data_t), target, intent(in) :: model
integer, intent(in), optional :: mode
if (.not. associated (cfg%model)) then
cfg%name = name
cfg%model => model
end if
if (present (mode)) cfg%mode = mode
end subroutine blha_configuration_init
@ %def blha_configuration_init
@ Create an array of massive particle indices, to be used by the
"MassiveParticle"-statement of the order file.
<<BLHA config: procedures>>=
subroutine blha_configuration_get_massive_particles &
(cfg, massive, i_massive)
type(blha_configuration_t), intent(in) :: cfg
logical, intent(out) :: massive
integer, intent(out), dimension(:), allocatable :: i_massive
integer, parameter :: max_particles = 10
integer, dimension(max_particles) :: i_massive_tmp
integer, dimension(max_particles) :: checked
type(blha_cfg_process_node_t), pointer :: current_process
integer :: k
integer :: n_massive
n_massive = 0; k = 1
checked = 0
if (associated (cfg%processes)) then
current_process => cfg%processes
else
call msg_fatal ("BLHA, massive particles: " // &
"No processes allocated!")
end if
do
call check_pdg_list (current_process%pdg_in%pdg)
call check_pdg_list (current_process%pdg_out%pdg)
if (k > max_particles) &
call msg_fatal ("BLHA, massive particles: " // &
"Max. number of particles exceeded!")
if (associated (current_process%next)) then
current_process => current_process%next
else
exit
end if
end do
if (n_massive > 0) then
allocate (i_massive (n_massive))
i_massive = i_massive_tmp (1:n_massive)
massive = .true.
else
massive = .false.
end if
contains
subroutine check_pdg_list (pdg_list)
integer, dimension(:), intent(in) :: pdg_list
integer :: i, i_pdg
type(flavor_t) :: flv
do i = 1, size (pdg_list)
i_pdg = abs (pdg_list(i))
call flv%init (i_pdg, cfg%model)
if (flv%get_mass () > 0._default) then
!!! Avoid duplicates in output
if (.not. any (checked == i_pdg)) then
i_massive_tmp(k) = i_pdg
checked(k) = i_pdg
k = k + 1
n_massive = n_massive + 1
end if
end if
end do
end subroutine check_pdg_list
end subroutine blha_configuration_get_massive_particles
@ %def blha_configuration_get_massive_particles
@
<<BLHA config: public>>=
public :: blha_configuration_append_processes
<<BLHA config: sub interfaces>>=
module subroutine blha_configuration_append_processes (cfg, n_in, flavor, amp_type)
type(blha_configuration_t), intent(inout) :: cfg
integer, intent(in) :: n_in
type(blha_flv_state_t), dimension(:), intent(in) :: flavor
integer, dimension(:), intent(in), optional :: amp_type
end subroutine blha_configuration_append_processes
<<BLHA config: procedures>>=
module subroutine blha_configuration_append_processes (cfg, n_in, flavor, amp_type)
type(blha_configuration_t), intent(inout) :: cfg
integer, intent(in) :: n_in
type(blha_flv_state_t), dimension(:), intent(in) :: flavor
integer, dimension(:), intent(in), optional :: amp_type
integer :: n_tot
type(blha_cfg_process_node_t), pointer :: current_node
integer :: i_process, i_flv
integer, dimension(:), allocatable :: pdg_in, pdg_out
integer, dimension(:), allocatable :: flavor_state
integer :: proc_offset, n_proc_tot
proc_offset = 0; n_proc_tot = 0
do i_flv = 1, size (flavor)
n_proc_tot = n_proc_tot + flavor(i_flv)%flv_mult
end do
if (.not. associated (cfg%processes)) &
allocate (cfg%processes)
current_node => cfg%processes
do i_flv = 1, size (flavor)
n_tot = size (flavor(i_flv)%flavors)
allocate (pdg_in (n_in), pdg_out (n_tot - n_in))
allocate (flavor_state (n_tot))
flavor_state = flavor(i_flv)%flavors
do i_process = 1, flavor(i_flv)%flv_mult
pdg_in = flavor_state (1 : n_in)
pdg_out = flavor_state (n_in + 1 : )
if (cfg%polarized) then
select case (cfg%mode)
case (BLHA_MODE_OPENLOOPS)
call allocate_and_init_pdg_and_helicities (current_node, &
pdg_in, pdg_out, amp_type (proc_offset + i_process))
case (BLHA_MODE_GOSAM)
!!! Nothing special for GoSam yet. This exception is already caught
!!! in blha_master_setup_additional_features
end select
else
call allocate_and_init_pdg (current_node, pdg_in, pdg_out, &
amp_type (proc_offset + i_process))
end if
if (proc_offset + i_process /= n_proc_tot) then
allocate (current_node%next)
current_node => current_node%next
end if
if (i_process == flavor(i_flv)%flv_mult) &
proc_offset = proc_offset + flavor(i_flv)%flv_mult
end do
deallocate (pdg_in, pdg_out)
deallocate (flavor_state)
end do
contains
subroutine allocate_and_init_pdg (node, pdg_in, pdg_out, amp_type)
type(blha_cfg_process_node_t), intent(inout), pointer :: node
integer, intent(in), dimension(:), allocatable :: pdg_in, pdg_out
integer, intent(in) :: amp_type
allocate (node%pdg_in (size (pdg_in)))
allocate (node%pdg_out (size (pdg_out)))
node%pdg_in%pdg = pdg_in
node%pdg_out%pdg = pdg_out
node%amplitude_type = amp_type
end subroutine allocate_and_init_pdg
subroutine allocate_and_init_pdg_and_helicities (node, pdg_in, pdg_out, amp_type)
type(blha_cfg_process_node_t), intent(inout), pointer :: node
integer, intent(in), dimension(:), allocatable :: pdg_in, pdg_out
integer, intent(in) :: amp_type
integer :: h1, h2
if (size (pdg_in) == 2) then
do h1 = -1, 1, 2
do h2 = -1, 1, 2
call allocate_and_init_pdg (current_node, pdg_in, pdg_out, amp_type)
current_node%pdg_in(1)%polarized = .true.
current_node%pdg_in(2)%polarized = .true.
current_node%pdg_in(1)%hel = h1
current_node%pdg_in(2)%hel = h2
if (h1 + h2 /= 2) then !!! not end of loop
allocate (current_node%next)
current_node => current_node%next
end if
end do
end do
else
do h1 = -1, 1, 2
call allocate_and_init_pdg (current_node, pdg_in, pdg_out, amp_type)
current_node%pdg_in(1)%polarized = .true.
current_node%pdg_in(1)%hel = h1
if (h1 /= 1) then !!! not end of loop
allocate (current_node%next)
current_node => current_node%next
end if
end do
end if
end subroutine allocate_and_init_pdg_and_helicities
end subroutine blha_configuration_append_processes
@ %def blha_configuration_append_processes
@ Change parameter(s).
<<BLHA config: public>>=
public :: blha_configuration_set
<<BLHA config: sub interfaces>>=
module subroutine blha_configuration_set (cfg, &
version, irreg, massive_particle_scheme, &
model_file, alphas_power, alpha_power, ew_scheme, width_scheme, &
accuracy, debug)
type(blha_configuration_t), intent(inout) :: cfg
integer, optional, intent(in) :: version
integer, optional, intent(in) :: irreg
integer, optional, intent(in) :: massive_particle_scheme
type(string_t), optional, intent(in) :: model_file
integer, optional, intent(in) :: alphas_power, alpha_power
integer, optional, intent(in) :: ew_scheme
integer, optional, intent(in) :: width_scheme
real(default), optional, intent(in) :: accuracy
logical, optional, intent(in) :: debug
end subroutine blha_configuration_set
<<BLHA config: procedures>>=
module subroutine blha_configuration_set (cfg, &
version, irreg, massive_particle_scheme, &
model_file, alphas_power, alpha_power, ew_scheme, width_scheme, &
accuracy, debug)
type(blha_configuration_t), intent(inout) :: cfg
integer, optional, intent(in) :: version
integer, optional, intent(in) :: irreg
integer, optional, intent(in) :: massive_particle_scheme
type(string_t), optional, intent(in) :: model_file
integer, optional, intent(in) :: alphas_power, alpha_power
integer, optional, intent(in) :: ew_scheme
integer, optional, intent(in) :: width_scheme
real(default), optional, intent(in) :: accuracy
logical, optional, intent(in) :: debug
if (present (version)) &
cfg%version = version
if (present (irreg)) &
cfg%irreg = irreg
if (present (massive_particle_scheme)) &
cfg%massive_particle_scheme = massive_particle_scheme
if (present (model_file)) &
cfg%model_file = model_file
if (present (alphas_power)) &
cfg%alphas_power = alphas_power
if (present (alpha_power)) &
cfg%alpha_power = alpha_power
if (present (ew_scheme)) &
cfg%ew_scheme = ew_scheme
if (present (width_scheme)) &
cfg%width_scheme = width_scheme
if (present (accuracy)) &
cfg%accuracy_target = accuracy
if (present (debug)) &
cfg%debug_unstable = debug
cfg%dirty = .false.
end subroutine blha_configuration_set
@ %def blha_configuration_set
@
<<BLHA config: public>>=
public :: blha_configuration_get_n_proc
<<BLHA config: sub interfaces>>=
module function blha_configuration_get_n_proc (cfg) result (n_proc)
type(blha_configuration_t), intent(in) :: cfg
integer :: n_proc
end function blha_configuration_get_n_proc
<<BLHA config: procedures>>=
module function blha_configuration_get_n_proc (cfg) result (n_proc)
type(blha_configuration_t), intent(in) :: cfg
integer :: n_proc
n_proc = cfg%n_proc
end function blha_configuration_get_n_proc
@ %def blha_configuration_get_n_proc
@
Write the BLHA file. Internal mode is intented for md5summing only.
Special cases of external photons in \texttt{OpenLoops}:
For electroweak corrections the particle ID (PID) of photons is a crucial input for the
computation of matrix elements by \texttt{OpenLoops}.
According to "arXiv: 1907.13071", section 3.2, external photons are classified by the
following types:
\begin{itemize}
\item PID $= -2002$: off-shell photons, that undergo $\gamma\rightarrow f\bar{f}$ splittings
at NLO EW, or initial state photons from QED PDFs
\item PID $= 2002$: on-shell photons, that do not undergo $\gamma\rightarrow f\bar{f}$
splittings at NLO EW, or initial state photons for example at photon colliders
\item PID $= 22$: unresolved photons, representing radiated photons at NLO EW, absent at LO
\end{itemize}
For the first two types scattering amplitudes for processes with external photons at NLO EW
get renormalisation factors containing photon-coupling and wave function counterterms.
Logarithmic mass singularities arising due to the renormalisation of off-shell external
photon wave functions are cancelled by collinear singularities of photon PDF counterterms or
analogous terms in virtual contributions originating from $\gamma\rightarrow f\bar{f}$
splittings of final state photons.
The finite remainders of the renormalisation factors are thus dictated by the specific photon
PID stated above.
As consequence, we have to adjust the input PIDs written into the BLHA file which will be
read by \texttt{OpenLoops}.\\
Concretely, for the case of electroweak corrections initial state photons associated with
photon PDFs and final state photons (if existent at LO) are labeled as off-shell photons with
PID "$-2002$".
On-shell photons with PID "$2002$" are neglected for now since to include them for processes
at NLO EW is non-trivial from the phenomenological point of view.
Processes at NLO EW typically are studied at high energy scales for which photon-induced
sub-processes in most cases can not be neglected.
However, on-shell, e.~g. tagged, photons are defined at low energy scales and thus the
process has to be described with external photon fields and couplings at two different
scales.
Another issue which has to be adressed if various photon PIDs are taken into account is that
real and virtual amplitudes have to be computed at the same order in $\alpha$ at a specific
scale for the subtraction scheme to be consistent.
The complication comes by the fact that the EW coupling $\alpha$ of each external photon in
the amplitudes will automatically be rescaled by \texttt{OpenLoops} corresponding to the
specific photon type.
Following eq. (3.30) of "arXiv: 1907.13071", by default the coupling of an on-shell photon
will be changed to $\alpha(0)$ and that of an off-shell photon to $\alpha_{G_\mu}$ if not
chosen already at a high scale, e.~g. $\alpha(M_Z)$.
In order to not spoil the IR cancellation \texttt{OpenLoops} supplies to register unresolved
photons with PID "22" describing a radiated photon at NLO EW for which the photon-coupling
$\alpha$ is left unchanged at the value which is computed with the electroweak input scheme
chosen by the user.
This is adopted here by labeling each emitted photon as unresolved with PID "22" if no
photons are present at LO.\\
For EW corrections the freedom to choose an electroweak input scheme is restricted, however,
since the number of external photons present at LO is not conserved for the corresponding
real flavor structures due to possible $\gamma \rightarrow f\bar{f}$ splittings.
This forbids to choose $\alpha=\alpha(0)$ since otherwise the order in $\alpha(0)$ is not
conserved in the real amplitudes corresponding to the factorizing Born process.
Consequently, for FKS the NLO components are not of the same order in $\alpha(0)$.
The option \texttt{\$blha\_ew\_scheme = "alpha\_0"} is thus refused for the case if EW
corrections are activated and photons are present at LO.
<<BLHA config: public>>=
public :: blha_configuration_write
<<BLHA config: sub interfaces>>=
module subroutine blha_configuration_write (cfg, suffix, unit, internal, no_version)
type(blha_configuration_t), intent(in) :: cfg
integer, intent(in), optional :: unit
logical, intent(in), optional :: internal, no_version
type(string_t), intent(in) :: suffix
end subroutine blha_configuration_write
<<BLHA config: procedures>>=
module subroutine blha_configuration_write (cfg, suffix, unit, internal, no_version)
type(blha_configuration_t), intent(in) :: cfg
integer, intent(in), optional :: unit
logical, intent(in), optional :: internal, no_version
type(string_t), intent(in) :: suffix
integer, dimension(:), allocatable :: pdg_flv
integer :: u
logical :: full, nlo3
type(string_t) :: buf
type(blha_cfg_process_node_t), pointer :: node
integer :: i
character(3) :: pdg_char
character(5) :: pdg_char_extra
character(4) :: hel_char
character(6) :: suffix_char
character(len=25), parameter :: pad = ""
logical :: write_process, no_v
no_v = .false. ; if (present (no_version)) no_v = no_version
u = given_output_unit (unit); if (u < 0) return
full = .true.; if (present (internal)) full = .not. internal
if (full .and. cfg%dirty) call msg_bug ( &
"BUG: attempted to write out a dirty BLHA configuration")
if (full) then
if (no_v) then
write (u, "(A)") "# BLHA order written by WHIZARD [version]"
else
write (u, "(A)") "# BLHA order written by WHIZARD <<Version>>"
end if
write (u, "(A)")
end if
select case (cfg%mode)
case (BLHA_MODE_GOSAM); buf = "GoSam"
case (BLHA_MODE_OPENLOOPS); buf = "OpenLoops"
case default; buf = "vanilla"
end select
write (u, "(A)") "# BLHA interface mode: " // char (buf)
write (u, "(A)") "# process: " // char (cfg%name)
write (u, "(A)") "# model: " // char (cfg%model%get_name ())
select case (cfg%version)
case (1); buf = "BLHA1"
case (2); buf = "BLHA2"
end select
write (u, '(A25,A)') "InterfaceVersion " // pad, char (buf)
select case (cfg%correction_type)
case (BLHA_CT_QCD); buf = "QCD"
case (BLHA_CT_EW); buf = "EW"
case default; buf = cfg%correction_type_other
end select
write (u,'(A25,A)') "CorrectionType" // pad, char (buf)
select case (cfg%mode)
case (BLHA_MODE_OPENLOOPS)
buf = cfg%name // '.olc'
write (u, '(A25,A)') "Extra AnswerFile" // pad, char (buf)
end select
select case (cfg%irreg)
case (BLHA_IRREG_CDR); buf = "CDR"
case (BLHA_IRREG_DRED); buf = "DRED"
case (BLHA_IRREG_THV); buf = "tHV"
case (BLHA_IRREG_MREG); buf = "MassReg"
case default; buf = cfg%irreg_other
end select
write (u,'(A25,A)') "IRregularisation" // pad, char (buf)
select case (cfg%massive_particle_scheme)
case (BLHA_MPS_ONSHELL); buf = "OnShell"
case default; buf = cfg%massive_particle_scheme_other
end select
if (cfg%mode == BLHA_MODE_GOSAM) &
write (u,'(A25,A)') "MassiveParticleScheme" // pad, char (buf)
select case (cfg%version)
case (1)
if (cfg%alphas_power >= 0) write (u,'(A25,A)') &
"AlphasPower" // pad, int2char (cfg%alphas_power)
if (cfg%alpha_power >= 0) write (u,'(A25,A)') &
"AlphaPower " // pad, int2char (cfg%alpha_power)
case (2)
if (cfg%alphas_power >= 0) write (u,'(A25,A)') &
"CouplingPower QCD " // pad, int2char (cfg%alphas_power)
if (cfg%alpha_power >= 0) write (u, '(A25,A)') &
"CouplingPower QED " // pad, int2char (cfg%alpha_power)
end select
select case (cfg%mode)
case (BLHA_MODE_GOSAM)
select case (cfg%ew_scheme)
case (BLHA_EW_GF, BLHA_EW_INTERNAL); buf = "alphaGF"
case (BLHA_EW_MZ); buf = "alphaMZ"
case (BLHA_EW_MSBAR); buf = "alphaMSbar"
case (BLHA_EW_0); buf = "alpha0"
case (BLHA_EW_RUN); buf = "alphaRUN"
end select
write (u, '(A25, A)') "EWScheme " // pad, char (buf)
case (BLHA_MODE_OPENLOOPS)
select case (cfg%ew_scheme)
case (BLHA_EW_0); buf = "alpha0"
case (BLHA_EW_GF); buf = "Gmu"
case (BLHA_EW_MZ, BLHA_EW_INTERNAL); buf = "alphaMZ"
case default
call msg_fatal ("OpenLoops input: Only supported EW schemes &
& are 'alpha0', 'Gmu', and 'alphaMZ'")
end select
write (u, '(A25, A)') "ewscheme " // pad, char (buf)
end select
select case (cfg%mode)
case (BLHA_MODE_GOSAM)
write (u, '(A25)', advance='no') "MassiveParticles " // pad
do i = 1, size (OLP_MASSIVE_PARTICLES)
if (OLP_MASSIVE_PARTICLES(i) > 0) &
write (u, '(I2,1X)', advance='no') OLP_MASSIVE_PARTICLES(i)
end do
write (u,*)
case (BLHA_MODE_OPENLOOPS)
if (cfg%openloops_use_cms) then
write (u, '(A25,I1)') "extra use_cms " // pad, 1
else
write (u, '(A25,I1)') "extra use_cms " // pad, 0
end if
write (u, '(A25,I1)') "extra me_cache " // pad, 0
!!! Turn off calculation of 1/eps & 1/eps^2 poles in one-loop calculation
!!! Not needed in FKS (or any numerical NLO subtraction scheme)
write (u, '(A25,I1)') "extra IR_on " // pad, 0
if (cfg%openloops_phs_tolerance > 0) then
write (u, '(A25,A4,I0)') "extra psp_tolerance " // pad, "10e-", &
cfg%openloops_phs_tolerance
end if
call check_extra_cmd (cfg%openloops_extra_cmd)
write (u, '(A)') char (cfg%openloops_extra_cmd)
if (cfg%openloops_allowed_libs /= '') then
write (u, '(A25,A)') "extra allowed_libs" // pad, &
char (cfg%openloops_allowed_libs)
end if
if (cfg%openloops_stability_log > 0) &
write (u, '(A25,I1)') "extra stability_log " // pad, &
cfg%openloops_stability_log
end select
if (full) then
write (u, "(A)")
write (u, "(A)") "# Process definitions"
write (u, "(A)")
end if
if (cfg%debug_unstable) &
write (u, '(A25,A)') "DebugUnstable " // pad, "True"
write (u, *)
node => cfg%processes
do while (associated (node))
write_process = .true.
allocate (pdg_flv (size (node%pdg_in) + size (node%pdg_out)))
do i = 1, size (node%pdg_in)
pdg_flv (i) = node%pdg_in(i)%pdg
end do
do i = 1, size (node%pdg_out)
pdg_flv (i + size (node%pdg_in)) = node%pdg_out(i)%pdg
end do
suffix_char = char (suffix)
if (cfg%correction_type == BLHA_CT_EW .and. cfg%alphas_power > 0) then
if ((suffix_char (1:5) == "_BORN" .and. .not. query_coupling_powers &
(pdg_flv, cfg%alpha_power, cfg%alphas_power)) .or. &
((suffix_char (1:4) == "_SUB" .or. suffix_char (1:5) == "_LOOP" .or. &
suffix_char (1:6) == "_DGLAP") .and. (.not. (query_coupling_powers &
(pdg_flv, cfg%alpha_power, cfg%alphas_power) .or. query_coupling_powers &
(pdg_flv, cfg%alpha_power + 1, cfg%alphas_power - 1)) .or. &
all (is_gluon (pdg_flv))))) then
deallocate (pdg_flv)
node => node%next
cycle
end if
end if
select case (node%amplitude_type)
case (BLHA_AMP_LOOP); buf = "Loop"
case (BLHA_AMP_COLOR_C); buf = "ccTree"
case (BLHA_AMP_SPIN_C)
if (cfg%mode == BLHA_MODE_OPENLOOPS) then
buf = "sctree_polvect"
else
buf = "scTree"
end if
case (BLHA_AMP_TREE); buf = "Tree"
case (BLHA_AMP_LOOPINDUCED); buf = "LoopInduced"
end select
nlo3 = qcd_ew_interferences (pdg_flv) .and. &
(node%amplitude_type == BLHA_AMP_COLOR_C .or. &
node%amplitude_type == BLHA_AMP_SPIN_C) .and. &
.not. query_coupling_powers (pdg_flv, cfg%alpha_power+2, cfg%alphas_power-2)
if (write_process) then
write (u, '(A25, A)') "AmplitudeType " // pad, char (buf)
buf = ""
if (cfg%correction_type == BLHA_CT_EW .and. cfg%alphas_power > 0 .and. &
(suffix_char (1:4) == "_SUB" .or. suffix_char (1:5) == "_LOOP" &
.or. suffix_char (1:6) == "_DGLAP")) then
if (query_coupling_powers (pdg_flv, cfg%alpha_power, cfg%alphas_power) &
.and. .not. nlo3) then
write (u,'(A25,A)') "CorrectionType" // pad, "EW"
select case (cfg%version)
case (1)
if (cfg%alphas_power >= 0) write (u,'(A25,A)') &
"AlphasPower" // pad, int2char (cfg%alphas_power)
if (cfg%alpha_power >= 0) write (u,'(A25,A)') &
"AlphaPower " // pad, int2char (cfg%alpha_power)
case (2)
if (cfg%alphas_power >= 0) write (u,'(A25,A)') &
"CouplingPower QCD " // pad, int2char (cfg%alphas_power)
if (cfg%alpha_power >= 0) write (u, '(A25,A)') &
"CouplingPower QED " // pad, int2char (cfg%alpha_power)
end select
else if (query_coupling_powers &
(pdg_flv, cfg%alpha_power + 1, cfg%alphas_power - 1)) then
write (u,'(A25,A)') "CorrectionType" // pad, "QCD"
select case (cfg%version)
case (1)
if (cfg%alphas_power >= 0) write (u,'(A25,A)') &
"AlphasPower" // pad, int2char (cfg%alphas_power - 1)
if (cfg%alpha_power >= 0) write (u,'(A25,A)') &
"AlphaPower " // pad, int2char (cfg%alpha_power + 1)
case (2)
if (cfg%alphas_power >= 0) write (u,'(A25,A)') &
"CouplingPower QCD " // pad, int2char (cfg%alphas_power - 1)
if (cfg%alpha_power >= 0) write (u, '(A25,A)') &
"CouplingPower QED " // pad, int2char (cfg%alpha_power + 1)
end select
end if
end if
do i = 1, size (node%pdg_in)
if (cfg%correction_type == BLHA_CT_EW .and. node%pdg_in(i)%pdg == PHOTON &
.and. cfg%n_off_photons_is > 0) then
if (cfg%ew_scheme == BLHA_EW_0) then
call msg_fatal ("ew_scheme: 'alpha_0' or 'alpha_thompson' " &
// "in combination", [ var_str ("with off-shell external photons " &
// "is not consistent with FKS.")])
end if
write (pdg_char_extra, '(I5)') PHOTON_OFFSHELL
buf = (buf // pdg_char_extra) // " "
else
call node%pdg_in(i)%write_pdg (pdg_char)
if (node%pdg_in(i)%polarized) then
call node%pdg_in(i)%write_helicity (hel_char)
buf = (buf // pdg_char // hel_char) // " "
else
buf = (buf // pdg_char) // " "
end if
end if
end do
buf = buf // "-> "
do i = 1, size (node%pdg_out)
if (cfg%correction_type == BLHA_CT_EW .and. node%pdg_out(i)%pdg == PHOTON &
.and. cfg%n_off_photons_fs > 0) then
if (cfg%ew_scheme == BLHA_EW_0) then
call msg_fatal ("ew_scheme: 'alpha_0' or 'alpha_thompson' " &
// "in combination with off-shell external photons " &
// "is not consistent with FKS. Try a different one.")
end if
write (pdg_char_extra, '(I5)') PHOTON_OFFSHELL
buf = (buf // pdg_char_extra) // " "
else
call node%pdg_out(i)%write_pdg (pdg_char)
buf = (buf // pdg_char) // " "
end if
end do
write (u, "(A)") char (trim (buf))
write (u, *)
end if
deallocate (pdg_flv)
node => node%next
end do
end subroutine blha_configuration_write
@ %def blha_configuration_write
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Module definition}
These modules implement the communication with one loop matrix element providers
according to the Binoth LesHouches Accord Interface. The actual matrix
element(s) are loaded as a dynamic library.
This module defines the common OLP-interfaces defined through the Binoth Les-Houches
accord.
<<[[blha_olp_interfaces.f90]]>>=
<<File header>>
module blha_olp_interfaces
use, intrinsic :: iso_c_binding !NODEP!
use, intrinsic :: iso_fortran_env
use kinds
<<Use strings>>
use os_interface
use lorentz
use interactions
use model_data
use prclib_interfaces
use process_libraries
use prc_core_def
use prc_core
use prc_external
use blha_config
<<Standard module head>>
<<BLHA OLP interfaces: public>>
<<BLHA OLP interfaces: public parameters>>
<<BLHA OLP interfaces: types>>
<<BLHA OLP interfaces: interfaces>>
interface
<<BLHA OLP interfaces: sub interfaces>>
end interface
end module blha_olp_interfaces
@ %def module blha_olp_interfaces
@
<<[[blha_olp_interfaces_sub.f90]]>>=
<<File header>>
submodule (blha_olp_interfaces) blha_olp_interfaces_s
<<Use debug>>
use constants
use numeric_utils, only: vanishes
use numeric_utils, only: extend_integer_array, crop_integer_array
use io_units
use string_utils
use physics_defs
use diagnostics
use sm_qcd
use flavors
use pdg_arrays, only: is_gluon, is_quark, qcd_ew_interferences
implicit none
<<BLHA OLP interfaces: parameters>>
contains
<<BLHA OLP interfaces: procedures>>
end submodule blha_olp_interfaces_s
@ %def blha_olp_interfaces_s
@
<<BLHA OLP interfaces: public>>=
public :: blha_template_t
<<BLHA OLP interfaces: types>>=
type :: blha_template_t
integer :: I_BORN = 0
integer :: I_REAL = 1
integer :: I_LOOP = 2
integer :: I_SUB = 3
integer :: I_DGLAP = 4
logical, dimension(0:4) :: compute_component
logical :: include_polarizations = .false.
logical :: switch_off_muon_yukawas = .false.
logical :: use_internal_color_correlations = .true.
real(default) :: external_top_yukawa = -1._default
integer :: ew_scheme
integer :: loop_method = BLHA_MODE_GENERIC
contains
<<BLHA OLP interfaces: blha template: TBP>>
end type blha_template_t
@ %def blha_template_t
@
<<BLHA OLP interfaces: blha template: TBP>>=
procedure :: write => blha_template_write
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine blha_template_write (blha_template, unit)
class(blha_template_t), intent(in) :: blha_template
integer, intent(in), optional :: unit
end subroutine blha_template_write
<<BLHA OLP interfaces: procedures>>=
module subroutine blha_template_write (blha_template, unit)
class(blha_template_t), intent(in) :: blha_template
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u,"(A,4(L1))") "Compute components: ", &
blha_template%compute_component
write (u,"(A,L1)") "Include polarizations: ", &
blha_template%include_polarizations
write (u,"(A,L1)") "Switch off muon yukawas: ", &
blha_template%switch_off_muon_yukawas
write (u,"(A,L1)") "Use internal color correlations: ", &
blha_template%use_internal_color_correlations
end subroutine blha_template_write
@ %def blha_template_write
@ Compute the total number of used helicity states for the given particle PDG
codes, given a model. Applies only if polarization is supported. This
yields the [[n_hel]] value as required below.
<<BLHA OLP interfaces: blha template: TBP>>=
procedure :: get_n_hel => blha_template_get_n_hel
<<BLHA OLP interfaces: sub interfaces>>=
module function blha_template_get_n_hel (blha_template, pdg, model) result (n_hel)
class(blha_template_t), intent(in) :: blha_template
integer, dimension(:), intent(in) :: pdg
class(model_data_t), intent(in), target :: model
integer :: n_hel
end function blha_template_get_n_hel
<<BLHA OLP interfaces: procedures>>=
module function blha_template_get_n_hel (blha_template, pdg, model) result (n_hel)
class(blha_template_t), intent(in) :: blha_template
integer, dimension(:), intent(in) :: pdg
class(model_data_t), intent(in), target :: model
integer :: n_hel
type(flavor_t) :: flv
integer :: f
n_hel = 1
if (blha_template%include_polarizations) then
do f = 1, size (pdg)
call flv%init (pdg(f), model)
n_hel = n_hel * flv%get_multiplicity ()
end do
end if
end function blha_template_get_n_hel
@ %def blha_template_get_n_hel
@
<<BLHA OLP interfaces: parameters>>=
integer, parameter :: I_ALPHA_0 = 1
integer, parameter :: I_GF = 2
integer, parameter :: I_ALPHA_MZ = 3
integer, parameter :: I_ALPHA_INTERNAL = 4
integer, parameter :: I_SW2 = 5
<<BLHA OLP interfaces: public>>=
public :: prc_blha_t
<<BLHA OLP interfaces: types>>=
type, abstract, extends (prc_external_t) :: prc_blha_t
integer :: n_particles
integer :: n_hel
integer :: n_proc
integer, dimension(:, :), allocatable :: i_tree, i_spin_c, i_color_c
integer, dimension(:, :), allocatable :: i_virt
integer, dimension(:, :), allocatable :: i_hel
logical, dimension(5) :: ew_parameter_mask
integer :: sqme_tree_pos
contains
<<BLHA OLP interfaces: prc blha: TBP>>
end type prc_blha_t
@ %def prc_blha_t
@
Obviously, this process-core type uses the BLHA interface.
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure, nopass :: uses_blha => prc_blha_uses_blha
<<BLHA OLP interfaces: sub interfaces>>=
module function prc_blha_uses_blha () result (flag)
logical :: flag
end function prc_blha_uses_blha
<<BLHA OLP interfaces: procedures>>=
module function prc_blha_uses_blha () result (flag)
logical :: flag
flag = .true.
end function prc_blha_uses_blha
@ %def prc_blha_uses_blha
@
<<BLHA OLP interfaces: public>>=
public :: blha_driver_t
<<BLHA OLP interfaces: types>>=
type, abstract, extends (prc_external_driver_t) :: blha_driver_t
type(string_t) :: contract_file
type(string_t) :: nlo_suffix
logical :: include_polarizations = .false.
logical :: switch_off_muon_yukawas = .false.
real(default) :: external_top_yukawa = -1.0
procedure(olp_start),nopass, pointer :: &
blha_olp_start => null ()
procedure(olp_eval), nopass, pointer :: &
blha_olp_eval => null()
procedure(olp_info), nopass, pointer :: &
blha_olp_info => null ()
procedure(olp_set_parameter), nopass, pointer :: &
blha_olp_set_parameter => null ()
procedure(olp_eval2), nopass, pointer :: &
blha_olp_eval2 => null ()
procedure(olp_option), nopass, pointer :: &
blha_olp_option => null ()
procedure(olp_polvec), nopass, pointer :: &
blha_olp_polvec => null ()
procedure(olp_finalize), nopass, pointer :: &
blha_olp_finalize => null ()
procedure(olp_print_parameter), nopass, pointer :: &
blha_olp_print_parameter => null ()
contains
<<BLHA OLP interfaces: blha driver: TBP>>
end type blha_driver_t
@
@ %def blha_driver_t
<<BLHA OLP interfaces: public>>=
public :: prc_blha_writer_t
<<BLHA OLP interfaces: types>>=
type, abstract, extends (prc_external_writer_t) :: prc_blha_writer_t
type(blha_configuration_t) :: blha_cfg
contains
<<BLHA OLP interfaces: blha writer: TBP>>
end type prc_blha_writer_t
@
@ %def prc_blha_writer_t
<<BLHA OLP interfaces: public>>=
public :: blha_def_t
<<BLHA OLP interfaces: types>>=
type, abstract, extends (prc_external_def_t) :: blha_def_t
type(string_t) :: suffix
contains
<<BLHA OLP interfaces: blha def: TBP>>
end type blha_def_t
@ %def blha_def_t
@
<<BLHA OLP interfaces: public>>=
public :: blha_state_t
<<BLHA OLP interfaces: types>>=
type, abstract, extends (prc_external_state_t) :: blha_state_t
contains
<<BLHA OLP interfaces: blha state: TBP>>
end type blha_state_t
@ %def blha_state_t
@
<<BLHA OLP interfaces: blha state: TBP>>=
procedure :: reset_new_kinematics => blha_state_reset_new_kinematics
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine blha_state_reset_new_kinematics (object)
class(blha_state_t), intent(inout) :: object
end subroutine blha_state_reset_new_kinematics
<<BLHA OLP interfaces: procedures>>=
module subroutine blha_state_reset_new_kinematics (object)
class(blha_state_t), intent(inout) :: object
object%new_kinematics = .true.
end subroutine blha_state_reset_new_kinematics
@ %def blha_state_reset_new_kinematics
@
<<BLHA OLP interfaces: public parameters>>=
integer, parameter, public :: OLP_PARAMETER_LIMIT = 10
integer, parameter, public :: OLP_MOMENTUM_LIMIT = 50
integer, parameter, public :: OLP_RESULTS_LIMIT = 60
<<BLHA OLP interfaces: public>>=
public :: olp_start
<<BLHA OLP interfaces: interfaces>>=
interface
subroutine olp_start (contract_file_name, ierr) bind (C,name = "OLP_Start")
import
character(kind = c_char, len = 1), intent(in) :: contract_file_name
integer(kind = c_int), intent(out) :: ierr
end subroutine olp_start
end interface
@ %def olp_start_interface
@
<<BLHA OLP interfaces: public>>=
public :: olp_eval
<<BLHA OLP interfaces: interfaces>>=
interface
subroutine olp_eval (label, momenta, mu, parameters, res) &
bind (C, name = "OLP_EvalSubProcess")
import
integer(kind = c_int), value, intent(in) :: label
real(kind = c_double), value, intent(in) :: mu
real(kind = c_double), dimension(OLP_MOMENTUM_LIMIT), intent(in) :: &
momenta
real(kind = c_double), dimension(OLP_PARAMETER_LIMIT), intent(in) :: &
parameters
real(kind = c_double), dimension(OLP_RESULTS_LIMIT), intent(out) :: res
end subroutine olp_eval
end interface
@ %def olp_eval interface
@
<<BLHA OLP interfaces: public>>=
public :: olp_info
<<BLHA OLP interfaces: interfaces>>=
interface
subroutine olp_info (olp_file, olp_version, message) bind(C)
import
character(kind = c_char), intent(inout), dimension(15) :: olp_file
character(kind = c_char), intent(inout), dimension(15) :: olp_version
character(kind = c_char), intent(inout), dimension(255) :: message
end subroutine olp_info
end interface
@ %def olp_info interface
@
<<BLHA OLP interfaces: public>>=
public :: olp_set_parameter
<<BLHA OLP interfaces: interfaces>>=
interface
subroutine olp_set_parameter &
(variable_name, real_part, complex_part, success) bind(C)
import
character(kind = c_char,len = 1), intent(in) :: variable_name
real(kind = c_double), intent(in) :: real_part, complex_part
integer(kind = c_int), intent(out) :: success
end subroutine olp_set_parameter
end interface
@ %def olp_set_parameter_interface
@
<<BLHA OLP interfaces: public>>=
public :: olp_eval2
<<BLHA OLP interfaces: interfaces>>=
interface
subroutine olp_eval2 (label, momenta, mu, res, acc) bind(C)
import
integer(kind = c_int), intent(in) :: label
real(kind = c_double), intent(in) :: mu
real(kind = c_double), dimension(OLP_MOMENTUM_LIMIT), intent(in) :: momenta
real(kind = c_double), dimension(OLP_RESULTS_LIMIT), intent(out) :: res
real(kind = c_double), intent(out) :: acc
end subroutine olp_eval2
end interface
@ %def olp_eval2 interface
@
<<BLHA OLP interfaces: public>>=
public :: olp_option
<<BLHA OLP interfaces: interfaces>>=
interface
subroutine olp_option (line, stat) bind(C)
import
character(kind = c_char, len=1), intent(in) :: line
integer(kind = c_int), intent(out) :: stat
end subroutine
end interface
@ %def olp_option_interface
@
<<BLHA OLP interfaces: public>>=
public :: olp_polvec
<<BLHA OLP interfaces: interfaces>>=
interface
subroutine olp_polvec (p, q, eps) bind(C)
import
real(kind = c_double), dimension(0:3), intent(in) :: p, q
real(kind = c_double), dimension(0:7), intent(out) :: eps
end subroutine
end interface
@ %def olp_polvec_interface
@
<<BLHA OLP interfaces: public>>=
public :: olp_finalize
<<BLHA OLP interfaces: interfaces>>=
interface
subroutine olp_finalize () bind(C)
import
end subroutine olp_finalize
end interface
@ %def olp_finalize_interface
@
<<BLHA OLP interfaces: public>>=
public :: olp_print_parameter
<<BLHA OLP interfaces: interfaces>>=
interface
subroutine olp_print_parameter (filename) bind(C)
import
character(kind = c_char, len = 1), intent(in) :: filename
end subroutine olp_print_parameter
end interface
@ %def olp_print_parameter_interface
@
<<BLHA OLP interfaces: public>>=
public :: blha_result_array_size
<<BLHA OLP interfaces: sub interfaces>>=
pure module function blha_result_array_size &
(n_part, amp_type) result (rsize)
integer, intent(in) :: n_part, amp_type
integer :: rsize
end function blha_result_array_size
<<BLHA OLP interfaces: procedures>>=
pure module function blha_result_array_size &
(n_part, amp_type) result (rsize)
integer, intent(in) :: n_part, amp_type
integer :: rsize
select case (amp_type)
case (BLHA_AMP_TREE)
rsize = 1
case (BLHA_AMP_LOOP)
rsize = 4
case (BLHA_AMP_COLOR_C)
rsize = n_part * (n_part - 1) / 2
case (BLHA_AMP_SPIN_C)
rsize = 2 * n_part**2
case default
rsize = 0
end select
end function blha_result_array_size
@ %def blha_result_array_size
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: create_momentum_array => prc_blha_create_momentum_array
<<BLHA OLP interfaces: sub interfaces>>=
module function prc_blha_create_momentum_array (object, p) result (mom)
class(prc_blha_t), intent(in) :: object
type(vector4_t), intent(in), dimension(:) :: p
real(double), dimension(5*object%n_particles) :: mom
end function prc_blha_create_momentum_array
<<BLHA OLP interfaces: procedures>>=
module function prc_blha_create_momentum_array (object, p) result (mom)
class(prc_blha_t), intent(in) :: object
type(vector4_t), intent(in), dimension(:) :: p
real(double), dimension(5*object%n_particles) :: mom
integer :: n, i, k
n = size (p)
if (n > 10) call msg_fatal ("Number of external particles exceeds" &
// "size of BLHA-internal momentum array")
mom = zero
k = 1
do i = 1, n
mom(k : k + 3) = vector4_get_components (p(i))
mom(k + 4) = invariant_mass (p(i))
k = k + 5
end do
end function prc_blha_create_momentum_array
@ %def prc_blha_create_momentum_array
@
<<BLHA OLP interfaces: blha template: TBP>>=
procedure :: init => blha_template_init
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine blha_template_init (template, requires_polarizations, &
switch_off_muon_yukawas, external_top_yukawa, ew_scheme)
class(blha_template_t), intent(inout) :: template
logical, intent(in) :: requires_polarizations, switch_off_muon_yukawas
real(default), intent(in) :: external_top_yukawa
type(string_t), intent(in) :: ew_scheme
end subroutine blha_template_init
<<BLHA OLP interfaces: procedures>>=
module subroutine blha_template_init (template, requires_polarizations, &
switch_off_muon_yukawas, external_top_yukawa, ew_scheme)
class(blha_template_t), intent(inout) :: template
logical, intent(in) :: requires_polarizations, switch_off_muon_yukawas
real(default), intent(in) :: external_top_yukawa
type(string_t), intent(in) :: ew_scheme
template%compute_component = .false.
template%include_polarizations = requires_polarizations
template%switch_off_muon_yukawas = switch_off_muon_yukawas
template%external_top_yukawa = external_top_yukawa
template%ew_scheme = ew_scheme_string_to_int (ew_scheme)
end subroutine blha_template_init
@ %def blha_template_init
@
<<BLHA OLP interfaces: blha template: TBP>>=
procedure :: set_born => blha_template_set_born
procedure :: set_real_trees => blha_template_set_real_trees
procedure :: set_loop => blha_template_set_loop
procedure :: set_subtraction => blha_template_set_subtraction
procedure :: set_dglap => blha_template_set_dglap
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine blha_template_set_born (template)
class(blha_template_t), intent(inout) :: template
end subroutine blha_template_set_born
module subroutine blha_template_set_real_trees (template)
class(blha_template_t), intent(inout) :: template
end subroutine blha_template_set_real_trees
module subroutine blha_template_set_loop (template)
class(blha_template_t), intent(inout) :: template
end subroutine blha_template_set_loop
module subroutine blha_template_set_subtraction (template)
class(blha_template_t), intent(inout) :: template
end subroutine blha_template_set_subtraction
module subroutine blha_template_set_dglap (template)
class(blha_template_t), intent(inout) :: template
end subroutine blha_template_set_dglap
<<BLHA OLP interfaces: procedures>>=
module subroutine blha_template_set_born (template)
class(blha_template_t), intent(inout) :: template
template%compute_component (template%I_BORN) = .true.
end subroutine blha_template_set_born
module subroutine blha_template_set_real_trees (template)
class(blha_template_t), intent(inout) :: template
template%compute_component (template%I_REAL) = .true.
end subroutine blha_template_set_real_trees
module subroutine blha_template_set_loop (template)
class(blha_template_t), intent(inout) :: template
template%compute_component(template%I_LOOP) = .true.
end subroutine blha_template_set_loop
module subroutine blha_template_set_subtraction (template)
class(blha_template_t), intent(inout) :: template
template%compute_component (template%I_SUB) = .true.
end subroutine blha_template_set_subtraction
module subroutine blha_template_set_dglap (template)
class(blha_template_t), intent(inout) :: template
template%compute_component (template%I_DGLAP) = .true.
end subroutine blha_template_set_dglap
@ %def blha_template_set_components
@
<<BLHA OLP interfaces: blha template: TBP>>=
procedure :: set_internal_color_correlations &
=> blha_template_set_internal_color_correlations
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine blha_template_set_internal_color_correlations (template)
class(blha_template_t), intent(inout) :: template
end subroutine blha_template_set_internal_color_correlations
<<BLHA OLP interfaces: procedures>>=
module subroutine blha_template_set_internal_color_correlations (template)
class(blha_template_t), intent(inout) :: template
template%use_internal_color_correlations = .true.
end subroutine blha_template_set_internal_color_correlations
@ %def blha_template_set_internal_color_correlations
@
<<BLHA OLP interfaces: blha template: TBP>>=
procedure :: get_internal_color_correlations &
=> blha_template_get_internal_color_correlations
<<BLHA OLP interfaces: sub interfaces>>=
pure module function blha_template_get_internal_color_correlations &
(template) result (val)
logical :: val
class(blha_template_t), intent(in) :: template
end function blha_template_get_internal_color_correlations
<<BLHA OLP interfaces: procedures>>=
pure module function blha_template_get_internal_color_correlations &
(template) result (val)
logical :: val
class(blha_template_t), intent(in) :: template
val = template%use_internal_color_correlations
end function blha_template_get_internal_color_correlations
@ %def blha_template_use_internal_color_correlations
@
<<BLHA OLP interfaces: blha template: TBP>>=
procedure :: compute_born => blha_template_compute_born
procedure :: compute_real_trees => blha_template_compute_real_trees
procedure :: compute_loop => blha_template_compute_loop
procedure :: compute_subtraction => blha_template_compute_subtraction
procedure :: compute_dglap => blha_template_compute_dglap
<<BLHA OLP interfaces: sub interfaces>>=
pure module function blha_template_compute_born (template) result (val)
class(blha_template_t), intent(in) :: template
logical :: val
end function blha_template_compute_born
pure module function blha_template_compute_real_trees (template) result (val)
class(blha_template_t), intent(in) :: template
logical :: val
end function blha_template_compute_real_trees
pure module function blha_template_compute_loop (template) result (val)
class(blha_template_t), intent(in) :: template
logical :: val
end function blha_template_compute_loop
pure module function blha_template_compute_subtraction (template) result (val)
class(blha_template_t), intent(in) :: template
logical :: val
end function blha_template_compute_subtraction
pure module function blha_template_compute_dglap (template) result (val)
class(blha_template_t), intent(in) :: template
logical :: val
end function blha_template_compute_dglap
<<BLHA OLP interfaces: procedures>>=
pure module function blha_template_compute_born (template) result (val)
class(blha_template_t), intent(in) :: template
logical :: val
val = template%compute_component (template%I_BORN)
end function blha_template_compute_born
pure module function blha_template_compute_real_trees (template) result (val)
class(blha_template_t), intent(in) :: template
logical :: val
val = template%compute_component (template%I_REAL)
end function blha_template_compute_real_trees
pure module function blha_template_compute_loop (template) result (val)
class(blha_template_t), intent(in) :: template
logical :: val
val = template%compute_component (template%I_LOOP)
end function blha_template_compute_loop
pure module function blha_template_compute_subtraction (template) result (val)
class(blha_template_t), intent(in) :: template
logical :: val
val = template%compute_component (template%I_SUB)
end function blha_template_compute_subtraction
pure module function blha_template_compute_dglap (template) result (val)
class(blha_template_t), intent(in) :: template
logical :: val
val = template%compute_component (template%I_DGLAP)
end function blha_template_compute_dglap
@ %def blha_template_compute
@
<<BLHA OLP interfaces: blha template: TBP>>=
procedure :: set_loop_method => blha_template_set_loop_method
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine blha_template_set_loop_method (template, master)
class(blha_template_t), intent(inout) :: template
class(blha_master_t), intent(in) :: master
end subroutine blha_template_set_loop_method
<<BLHA OLP interfaces: procedures>>=
module subroutine blha_template_set_loop_method (template, master)
class(blha_template_t), intent(inout) :: template
class(blha_master_t), intent(in) :: master
template%loop_method = master%blha_mode(1)
end subroutine blha_template_set_loop_method
@ %def blha_template_set_loop_method
@
<<BLHA OLP interfaces: blha template: TBP>>=
procedure :: check => blha_template_check
<<BLHA OLP interfaces: sub interfaces>>=
module function blha_template_check (template) result (val)
class(blha_template_t), intent(in) :: template
logical :: val
end function blha_template_check
<<BLHA OLP interfaces: procedures>>=
module function blha_template_check (template) result (val)
class(blha_template_t), intent(in) :: template
logical :: val
val = count (template%compute_component) == 1
end function blha_template_check
@ %def blha_template_check
@
<<BLHA OLP interfaces: blha template: TBP>>=
procedure :: reset => blha_template_reset
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine blha_template_reset (template)
class(blha_template_t), intent(inout) :: template
end subroutine blha_template_reset
<<BLHA OLP interfaces: procedures>>=
module subroutine blha_template_reset (template)
class(blha_template_t), intent(inout) :: template
template%compute_component = .false.
end subroutine blha_template_reset
@ %def blha_template_reset
@
<<BLHA OLP interfaces: blha writer: TBP>>=
procedure :: write => prc_blha_writer_write
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_writer_write (writer, unit)
class(prc_blha_writer_t), intent(in) :: writer
integer, intent(in) :: unit
end subroutine prc_blha_writer_write
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_writer_write (writer, unit)
class(prc_blha_writer_t), intent(in) :: writer
integer, intent(in) :: unit
write (unit, "(1x,A)") char (writer%get_process_string ())
end subroutine prc_blha_writer_write
@
@ %def prc_blha_writer_write
<<BLHA OLP interfaces: blha writer: TBP>>=
procedure :: get_process_string => prc_blha_writer_get_process_string
<<BLHA OLP interfaces: sub interfaces>>=
module function prc_blha_writer_get_process_string (writer) result (s_proc)
class(prc_blha_writer_t), intent(in) :: writer
type(string_t) :: s_proc
end function prc_blha_writer_get_process_string
<<BLHA OLP interfaces: procedures>>=
module function prc_blha_writer_get_process_string (writer) result (s_proc)
class(prc_blha_writer_t), intent(in) :: writer
type(string_t) :: s_proc
s_proc = var_str ("")
end function prc_blha_writer_get_process_string
@ %def prc_blha_writer_get_process_string
@
<<BLHA OLP interfaces: blha writer: TBP>>=
procedure :: get_n_proc => prc_blha_writer_get_n_proc
<<BLHA OLP interfaces: sub interfaces>>=
module function prc_blha_writer_get_n_proc (writer) result (n_proc)
class(prc_blha_writer_t), intent(in) :: writer
integer :: n_proc
end function prc_blha_writer_get_n_proc
<<BLHA OLP interfaces: procedures>>=
module function prc_blha_writer_get_n_proc (writer) result (n_proc)
class(prc_blha_writer_t), intent(in) :: writer
integer :: n_proc
n_proc = blha_configuration_get_n_proc (writer%blha_cfg)
end function prc_blha_writer_get_n_proc
@ %def prc_blha_writer_get_n_proc
@
<<BLHA OLP interfaces: blha driver: TBP>>=
procedure(blha_driver_set_GF), deferred :: &
set_GF
<<BLHA OLP interfaces: interfaces>>=
abstract interface
subroutine blha_driver_set_GF (driver, GF)
import
class(blha_driver_t), intent(inout) :: driver
real(default), intent(in) :: GF
end subroutine blha_driver_set_GF
end interface
@ %def blha_driver_set_GF
@
<<BLHA OLP interfaces: blha driver: TBP>>=
procedure(blha_driver_set_alpha_s), deferred :: &
set_alpha_s
<<BLHA OLP interfaces: interfaces>>=
abstract interface
subroutine blha_driver_set_alpha_s (driver, alpha_s)
import
class(blha_driver_t), intent(in) :: driver
real(default), intent(in) :: alpha_s
end subroutine blha_driver_set_alpha_s
end interface
@ %def set_alpha_s interface
@
<<BLHA OLP interfaces: blha driver: TBP>>=
procedure(blha_driver_set_weinberg_angle), deferred :: &
set_weinberg_angle
<<BLHA OLP interfaces: interfaces>>=
abstract interface
subroutine blha_driver_set_weinberg_angle (driver, sw2)
import
class(blha_driver_t), intent(inout) :: driver
real(default), intent(in) :: sw2
end subroutine blha_driver_set_weinberg_angle
end interface
@ %def blha_driver_set_weinberg_angle
@
<<BLHA OLP interfaces: blha driver: TBP>>=
procedure(blha_driver_set_alpha_qed), deferred :: set_alpha_qed
<<BLHA OLP interfaces: interfaces>>=
abstract interface
subroutine blha_driver_set_alpha_qed (driver, alpha)
import
class(blha_driver_t), intent(inout) :: driver
real(default), intent(in) :: alpha
end subroutine blha_driver_set_alpha_qed
end interface
@ %def blha_driver_set_alpha_qed
@
<<BLHA OLP interfaces: blha driver: TBP>>=
procedure(blha_driver_print_alpha_s), deferred :: &
print_alpha_s
<<BLHA OLP interfaces: interfaces>>=
abstract interface
subroutine blha_driver_print_alpha_s (object)
import
class(blha_driver_t), intent(in) :: object
end subroutine blha_driver_print_alpha_s
end interface
@ %def print_alpha_s interface
@
<<BLHA OLP interfaces: public>>=
public :: parameter_error_message
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine parameter_error_message (par, subr)
type(string_t), intent(in) :: par, subr
end subroutine parameter_error_message
<<BLHA OLP interfaces: procedures>>=
module subroutine parameter_error_message (par, subr)
type(string_t), intent(in) :: par, subr
type(string_t) :: message
message = "Setting of parameter " // par &
// "failed in " // subr // "!"
call msg_fatal (char (message))
end subroutine parameter_error_message
@ %def parameter_error_message
@
<<BLHA OLP interfaces: public>>=
public :: ew_parameter_error_message
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine ew_parameter_error_message (par)
type(string_t), intent(in) :: par
end subroutine ew_parameter_error_message
<<BLHA OLP interfaces: procedures>>=
module subroutine ew_parameter_error_message (par)
type(string_t), intent(in) :: par
type(string_t) :: message
message = "Setting of parameter " // par &
// "failed. This happens because the chosen " &
// "EWScheme in the BLHA file does not fit " &
// "your parameter choice"
call msg_fatal (char (message))
end subroutine ew_parameter_error_message
@ %def ew_parameter_error_message
@
<<BLHA OLP interfaces: blha driver: TBP>>=
procedure :: set_mass_and_width => blha_driver_set_mass_and_width
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine blha_driver_set_mass_and_width &
(driver, i_pdg, mass, width)
class(blha_driver_t), intent(inout) :: driver
integer, intent(in) :: i_pdg
real(default), intent(in), optional :: mass
real(default), intent(in), optional :: width
end subroutine blha_driver_set_mass_and_width
<<BLHA OLP interfaces: procedures>>=
module subroutine blha_driver_set_mass_and_width &
(driver, i_pdg, mass, width)
class(blha_driver_t), intent(inout) :: driver
integer, intent(in) :: i_pdg
real(default), intent(in), optional :: mass
real(default), intent(in), optional :: width
type(string_t) :: buf
character(kind=c_char,len=20) :: c_string
integer :: ierr
if (present (mass)) then
buf = 'mass(' // str (abs(i_pdg)) // ')'
c_string = char(buf) // c_null_char
call driver%blha_olp_set_parameter &
(c_string, dble(mass), 0._double, ierr)
if (ierr == 0) then
buf = "BLHA driver: Attempt to set mass of particle " // &
str (abs(i_pdg)) // "failed"
call msg_fatal (char(buf))
end if
end if
if (present (width)) then
buf = 'width(' // str (abs(i_pdg)) // ')'
c_string = char(buf)//c_null_char
call driver%blha_olp_set_parameter &
(c_string, dble(width), 0._double, ierr)
if (ierr == 0) then
buf = "BLHA driver: Attempt to set width of particle " // &
str (abs(i_pdg)) // "failed"
call msg_fatal (char(buf))
end if
end if
end subroutine blha_driver_set_mass_and_width
@ %def blha_driver_set_mass_and_width
@
<<BLHA OLP interfaces: blha driver: TBP>>=
procedure(blha_driver_init_dlaccess_to_library), deferred :: &
init_dlaccess_to_library
<<BLHA OLP interfaces: interfaces>>=
abstract interface
subroutine blha_driver_init_dlaccess_to_library &
(object, os_data, dlaccess, success)
import
class(blha_driver_t), intent(in) :: object
type(os_data_t), intent(in) :: os_data
type(dlaccess_t), intent(out) :: dlaccess
logical, intent(out) :: success
end subroutine blha_driver_init_dlaccess_to_library
end interface
@ %def interface blha_driver_init_dlaccess_to_library
@
<<BLHA OLP interfaces: blha driver: TBP>>=
procedure :: load => blha_driver_load
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine blha_driver_load (object, os_data, success)
class(blha_driver_t), intent(inout) :: object
type(os_data_t), intent(in) :: os_data
logical, intent(out) :: success
end subroutine blha_driver_load
<<BLHA OLP interfaces: procedures>>=
module subroutine blha_driver_load (object, os_data, success)
class(blha_driver_t), intent(inout) :: object
type(os_data_t), intent(in) :: os_data
logical, intent(out) :: success
type(dlaccess_t) :: dlaccess
type(c_funptr) :: c_fptr
logical :: init_success
call object%init_dlaccess_to_library (os_data, dlaccess, init_success)
c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Start"))
call c_f_procpointer (c_fptr, object%blha_olp_start)
call check_for_error (var_str ("OLP_Start"))
c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_EvalSubProcess"))
call c_f_procpointer (c_fptr, object%blha_olp_eval)
call check_for_error (var_str ("OLP_EvalSubProcess"))
c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Info"))
call c_f_procpointer (c_fptr, object%blha_olp_info)
call check_for_error (var_str ("OLP_Info"))
c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_SetParameter"))
call c_f_procpointer (c_fptr, object%blha_olp_set_parameter)
call check_for_error (var_str ("OLP_SetParameter"))
c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_EvalSubProcess2"))
call c_f_procpointer (c_fptr, object%blha_olp_eval2)
call check_for_error (var_str ("OLP_EvalSubProcess2"))
!!! The following three functions are not implemented in OpenLoops.
!!! In another BLHA provider, they need to be implemented separately.
!!! c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Option"))
!!! call c_f_procpointer (c_fptr, object%blha_olp_option)
!!! call check_for_error (var_str ("OLP_Option"))
!!! c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Polvec"))
!!! call c_f_procpointer (c_fptr, object%blha_olp_polvec)
!!! call check_for_error (var_str ("OLP_Polvec"))
!!! c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Finalize"))
!!! call c_f_procpointer (c_fptr, object%blha_olp_finalize)
!!! call check_for_error (var_str ("OLP_Finalize"))
c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_PrintParameter"))
call c_f_procpointer (c_fptr, object%blha_olp_print_parameter)
call check_for_error (var_str ("OLP_PrintParameter"))
success = .true.
contains
subroutine check_for_error (function_name)
type(string_t), intent(in) :: function_name
if (dlaccess_has_error (dlaccess)) &
call msg_fatal (char ("Loading of " // function_name // " failed!"))
end subroutine check_for_error
end subroutine blha_driver_load
@ %def blha_driver_load
@
<<BLHA OLP interfaces: parameters>>=
integer, parameter :: LEN_MAX_FLAVOR_STRING = 100
integer, parameter :: N_MAX_FLAVORS = 100
<<BLHA OLP interfaces: blha driver: TBP>>=
procedure :: read_contract_file => blha_driver_read_contract_file
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine blha_driver_read_contract_file (driver, flavors, &
amp_type, flv_index, hel_index, label, helicities)
class(blha_driver_t), intent(inout) :: driver
integer, intent(in), dimension(:,:) :: flavors
integer, intent(out), dimension(:), allocatable :: amp_type, &
flv_index, hel_index, label
integer, intent(out), dimension(:,:) :: helicities
end subroutine blha_driver_read_contract_file
<<BLHA OLP interfaces: procedures>>=
module subroutine blha_driver_read_contract_file (driver, flavors, &
amp_type, flv_index, hel_index, label, helicities)
class(blha_driver_t), intent(inout) :: driver
integer, intent(in), dimension(:,:) :: flavors
integer, intent(out), dimension(:), allocatable :: amp_type, &
flv_index, hel_index, label
integer, intent(out), dimension(:,:) :: helicities
integer :: unit, filestat
character(len=LEN_MAX_FLAVOR_STRING) :: rd_line
logical :: read_flavor, give_warning
integer :: label_count, i_flv, i
integer :: i_hel, n_in
integer :: i_next, n_entries
integer, dimension(size(flavors, 1) + 2) :: i_array
integer, dimension(size(flavors, 1) + 2) :: hel_array
integer, dimension(size(flavors, 1)) :: flv_array
integer, parameter :: NO_NUMBER = -1000
integer, parameter :: PROC_NOT_FOUND = -1001
integer, parameter :: list_incr = 50
integer :: n_found
allocate (amp_type (N_MAX_FLAVORS), flv_index (N_MAX_FLAVORS), &
hel_index (N_MAX_FLAVORS), label (N_MAX_FLAVORS))
amp_type = -1; flv_index = -1; hel_index = -1; label = -1
helicities = 0
n_in = size (helicities, dim = 2)
n_entries = size (flavors, 1) + 2
unit = free_unit ()
open (unit, file = char (driver%contract_file), status="old")
read_flavor = .false.
label_count = 1
i_hel = 1
n_found = 0
give_warning = .false.
do
read (unit, "(A)", iostat = filestat) rd_line
if (filestat == iostat_end) then
exit
else
if (rd_line(1:13) == 'AmplitudeType') then
if (i_hel > 2 * n_in) i_hel = 1
i_next = find_next_word_index (rd_line, 13)
if (label_count > size (amp_type)) &
call extend_integer_array (amp_type, list_incr)
if (rd_line(i_next : i_next + 4) == 'Loop') then
amp_type(label_count) = BLHA_AMP_LOOP
else if (rd_line(i_next : i_next + 4) == 'Tree') then
amp_type(label_count) = BLHA_AMP_TREE
else if (rd_line(i_next : i_next + 6) == 'ccTree') then
amp_type(label_count) = BLHA_AMP_COLOR_C
else if (rd_line(i_next : i_next + 6) == 'scTree' .or. &
rd_line(i_next : i_next + 14) == 'sctree_polvect') then
amp_type(label_count) = BLHA_AMP_SPIN_C
else
call msg_fatal ("AmplitudeType present but AmpType not known!")
end if
read_flavor = .true.
else if (read_flavor .and. .not. (rd_line(1:13) == 'CouplingPower' &
.or. rd_line(1:14) == 'CorrectionType')) then
i_array = create_flavor_string (rd_line, n_entries)
if (driver%include_polarizations) then
hel_array = create_helicity_string (rd_line, n_entries)
call check_helicity_array (hel_array, n_entries, n_in)
else
hel_array = 0
end if
if (.not. all (i_array == PROC_NOT_FOUND)) then
do i_flv = 1, size (flavors, 2)
flv_array = 0
do i = 1, size (flv_array)
if (i_array (i) == PHOTON_OFFSHELL .and. &
flavors (i, i_flv) == PHOTON) then
flv_array (i) = i_array (i)
else
flv_array (i) = flavors (i, i_flv)
end if
end do
if (all (i_array (1 : n_entries - 2) == flv_array (:))) then
if (label_count > size (label)) &
call extend_integer_array (label, list_incr)
label(label_count) = i_array (n_entries)
if (label_count > size (flv_index)) &
call extend_integer_array (flv_index, list_incr)
flv_index (label_count) = i_flv
if (label_count > size (hel_index)) &
call extend_integer_array (hel_index, list_incr)
hel_index (label_count) = i_hel
if (driver%include_polarizations) then
helicities (label(label_count), :) = hel_array (1:n_in)
i_hel = i_hel + 1
end if
n_found = n_found + 1
label_count = label_count + 1
exit
end if
end do
give_warning = .false.
else
give_warning = .true.
end if
read_flavor = .false.
end if
end if
end do
call crop_integer_array (amp_type, label_count-1)
if (n_found == 0) then
call msg_fatal ("The desired process has not been found ", &
[var_str ("by the OLP-Provider. Maybe the value of alpha_power "), &
var_str ("or alphas_power does not correspond to the process. "), &
var_str ("If you are using OpenLoops, you can set the option "), &
var_str ("openloops_verbosity to a value larger than 1 to obtain "), &
var_str ("more information")])
else if (give_warning) then
call msg_warning ("Some processes have not been found in the OLC file.", &
[var_str ("This is because these processes do not fit the required "), &
var_str ("coupling alpha_power and alphas_power. Be aware that the "), &
var_str ("results of this calculation are not necessarily an accurate "), &
var_str ("description of the physics of interest.")])
end if
close(unit)
contains
function create_flavor_string (s, n_entries) result (i_array)
character(len=LEN_MAX_FLAVOR_STRING), intent(in) :: s
integer, intent(in) :: n_entries
integer, dimension(n_entries) :: i_array
integer :: k, current_position
integer :: i_entry
k = 1; current_position = 1
do
if (current_position > LEN_MAX_FLAVOR_STRING) &
call msg_fatal ("Read OLC File: Current position exceeds maximum value")
if (s(current_position:current_position) /= " ") then
call create_flavor (s, i_entry, current_position)
if (i_entry /= NO_NUMBER .and. i_entry /= PROC_NOT_FOUND) then
i_array(k) = i_entry
k = k + 1
if (k > n_entries) then
return
else
call increment_current_position (s, current_position)
end if
else if (i_entry == PROC_NOT_FOUND) then
i_array = PROC_NOT_FOUND
return
else
call increment_current_position (s, current_position)
end if
else
call increment_current_position (s, current_position)
end if
end do
end function create_flavor_string
function create_helicity_string (s, n_entries) result (hel_array)
character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: s
integer, intent(in) :: n_entries
integer, dimension(n_entries) :: hel_array
integer :: k, current_position
integer :: hel
k = 1; current_position = 1
do
if (current_position > LEN_MAX_FLAVOR_STRING) &
call msg_fatal ("Read OLC File: Current position exceeds maximum value")
if (s(current_position:current_position) /= " ") then
call create_helicity (s, hel, current_position)
if (hel >= -1 .and. hel <= 1) then
hel_array(k) = hel
k = k + 1
if (k > n_entries) then
return
else
call increment_current_position (s, current_position)
end if
else
call increment_current_position (s, current_position)
end if
else
call increment_current_position (s, current_position)
end if
end do
end function create_helicity_string
subroutine increment_current_position (s, current_position)
character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: s
integer, intent(inout) :: current_position
current_position = find_next_word_index (s, current_position)
end subroutine increment_current_position
subroutine get_next_buffer (s, current_position, buf, last_buffer_index)
character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: s
integer, intent(inout) :: current_position
character(len = 10), intent(out) :: buf
integer, intent(out) :: last_buffer_index
integer :: i
i = 1; buf = ""
do
if (s(current_position:current_position) /= " ") then
buf(i:i) = s(current_position:current_position)
i = i + 1; current_position = current_position + 1
else
exit
end if
end do
last_buffer_index = i
end subroutine get_next_buffer
function is_particle_buffer (buf, i) result (valid)
logical :: valid
character(len = 10), intent(in) :: buf
integer, intent(in) :: i
valid = (buf(1 : i - 1) /= "->" .and. buf(1 : i - 1) /= "|" &
.and. buf(1 : i - 1) /= "Process")
end function is_particle_buffer
subroutine create_flavor (s, i_particle, current_position)
character(len=LEN_MAX_FLAVOR_STRING), intent(in) :: s
integer, intent(out) :: i_particle
integer, intent(inout) :: current_position
character(len=10) :: buf
integer :: i, last_buffer_index
call get_next_buffer (s, current_position, buf, last_buffer_index)
i = last_buffer_index
if (is_particle_buffer (buf, i)) then
call strip_helicity (buf, i)
i_particle = read_ival (var_str (buf(1 : i - 1)))
else if (buf(1 : i - 1) == "Process") then
i_particle = PROC_NOT_FOUND
else
i_particle = NO_NUMBER
end if
end subroutine create_flavor
subroutine create_helicity (s, helicity, current_position)
character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: s
integer, intent(out) :: helicity
integer, intent(inout) :: current_position
character(len = 10) :: buf
integer :: i, last_buffer_index
logical :: success
call get_next_buffer (s, current_position, buf, last_buffer_index)
i = last_buffer_index
if (is_particle_buffer (buf, i)) then
call strip_flavor (buf, i, helicity, success)
else
helicity = 0
end if
end subroutine create_helicity
subroutine strip_helicity (buf, i)
character(len = 10), intent(in) :: buf
integer, intent(inout) :: i
integer :: i_last
i_last = i - 1
if (i_last < 4) return
if (buf(i_last - 2 : i_last) == "(1)") then
i = i - 3
else if (buf(i_last - 3 : i_last) == "(-1)") then
i = i - 4
end if
end subroutine strip_helicity
subroutine strip_flavor (buf, i, helicity, success)
character(len = 10), intent(in) :: buf
integer, intent(in) :: i
integer, intent(out) :: helicity
logical, intent(out) :: success
integer :: i_last
i_last = i - 1
helicity = 0
if (i_last < 4) return
if (buf(i_last - 2 : i_last) == "(1)") then
helicity = 1
success = .true.
else if (buf(i_last - 3 : i_last) == "(-1)") then
helicity = -1
success = .true.
else
success = .false.
end if
end subroutine strip_flavor
function find_next_word_index (word, i_start) result (i_next)
character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: word
integer, intent(in) :: i_start
integer :: i_next
i_next = i_start + 1
do
if (word(i_next : i_next) /= " ") then
exit
else
i_next = i_next + 1
end if
if (i_next > LEN_MAX_FLAVOR_STRING) &
call msg_fatal ("Find next word: line limit exceeded")
end do
end function find_next_word_index
subroutine check_helicity_array (hel_array, n_entries, n_in)
integer, intent(in), dimension(:) :: hel_array
integer, intent(in) :: n_entries, n_in
integer :: n_particles, i
logical :: valid
n_particles = n_entries - 2
!!! only allow polarisations for incoming fermions for now
valid = all (hel_array (n_in + 1 : n_particles) == 0)
do i = 1, n_in
valid = valid .and. (hel_array(i) == 1 .or. hel_array(i) == -1)
end do
if (.not. valid) &
call msg_fatal ("Invalid helicities encountered!")
end subroutine check_helicity_array
end subroutine blha_driver_read_contract_file
@ %def blha_driver_read_contract_file
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: set_alpha_qed => prc_blha_set_alpha_qed
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_set_alpha_qed (object, model)
class(prc_blha_t), intent(inout) :: object
type(model_data_t), intent(in), target :: model
end subroutine prc_blha_set_alpha_qed
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_set_alpha_qed (object, model)
class(prc_blha_t), intent(inout) :: object
type(model_data_t), intent(in), target :: model
real(default) :: alpha
alpha = one / model%get_real (var_str ('alpha_em_i'))
select type (driver => object%driver)
class is (blha_driver_t)
call driver%set_alpha_qed (alpha)
end select
end subroutine prc_blha_set_alpha_qed
@ %def prc_blha_set_alpha_qed
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: set_GF => prc_blha_set_GF
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_set_GF (object, model)
class(prc_blha_t), intent(inout) :: object
type(model_data_t), intent(in), target :: model
end subroutine prc_blha_set_GF
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_set_GF (object, model)
class(prc_blha_t), intent(inout) :: object
type(model_data_t), intent(in), target :: model
real(default) :: GF
GF = model%get_real (var_str ('GF'))
select type (driver => object%driver)
class is (blha_driver_t)
call driver%set_GF (GF)
end select
end subroutine prc_blha_set_GF
@ %def prc_blha_set_GF
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: set_weinberg_angle => prc_blha_set_weinberg_angle
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_set_weinberg_angle (object, model)
class(prc_blha_t), intent(inout) :: object
type(model_data_t), intent(in), target :: model
end subroutine prc_blha_set_weinberg_angle
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_set_weinberg_angle (object, model)
class(prc_blha_t), intent(inout) :: object
type(model_data_t), intent(in), target :: model
real(default) :: sw2
sw2 = model%get_real (var_str ('sw2'))
select type (driver => object%driver)
class is (blha_driver_t)
call driver%set_weinberg_angle (sw2)
end select
end subroutine prc_blha_set_weinberg_angle
@ %def prc_blha_set_weinberg_angle
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: set_electroweak_parameters => &
prc_blha_set_electroweak_parameters
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_set_electroweak_parameters (object, model)
class(prc_blha_t), intent(inout) :: object
type(model_data_t), intent(in), target :: model
end subroutine prc_blha_set_electroweak_parameters
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_set_electroweak_parameters (object, model)
class(prc_blha_t), intent(inout) :: object
type(model_data_t), intent(in), target :: model
if (count (object%ew_parameter_mask) == 0) then
call msg_fatal ("Cannot decide EW parameter setting: No scheme set!")
else if (count (object%ew_parameter_mask) > 1) then
call msg_fatal ("Cannot decide EW parameter setting: More than one scheme set!")
end if
if (object%ew_parameter_mask (I_ALPHA_INTERNAL)) call object%set_alpha_qed (model)
if (object%ew_parameter_mask (I_GF)) call object%set_GF (model)
if (object%ew_parameter_mask (I_SW2)) call object%set_weinberg_angle (model)
end subroutine prc_blha_set_electroweak_parameters
@ %def prc_blha_set_electrweak_parameters
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: read_contract_file => prc_blha_read_contract_file
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_read_contract_file (object, flavors)
class(prc_blha_t), intent(inout) :: object
integer, intent(in), dimension(:,:) :: flavors
end subroutine prc_blha_read_contract_file
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_read_contract_file (object, flavors)
class(prc_blha_t), intent(inout) :: object
integer, intent(in), dimension(:,:) :: flavors
integer, dimension(:), allocatable :: amp_type, flv_index, hel_index, label
integer, dimension(:,:), allocatable :: helicities
integer :: i_proc, i_hel
allocate (helicities (N_MAX_FLAVORS, object%data%n_in))
select type (driver => object%driver)
class is (blha_driver_t)
call driver%read_contract_file (flavors, amp_type, flv_index, &
hel_index, label, helicities)
end select
object%n_proc = count (amp_type >= 0)
do i_proc = 1, object%n_proc
if (amp_type (i_proc) < 0) exit
if (hel_index(i_proc) < 0 .and. object%includes_polarization ()) &
call msg_bug ("Object includes polarization, but helicity index is undefined.")
i_hel = hel_index (i_proc)
select case (amp_type (i_proc))
case (BLHA_AMP_TREE)
if (allocated (object%i_tree)) then
object%i_tree(flv_index(i_proc), i_hel) = label(i_proc)
else
call msg_fatal ("Tree matrix element present, &
&but neither Born nor real indices are allocated!")
end if
case (BLHA_AMP_COLOR_C)
if (allocated (object%i_color_c)) then
object%i_color_c(flv_index(i_proc), i_hel) = label(i_proc)
else
call msg_fatal ("Color-correlated matrix element present, &
&but cc-indices are not allocated!")
end if
case (BLHA_AMP_SPIN_C)
if (allocated (object%i_spin_c)) then
object%i_spin_c(flv_index(i_proc), i_hel) = label(i_proc)
else
call msg_fatal ("Spin-correlated matrix element present, &
&but sc-indices are not allocated!")
end if
case (BLHA_AMP_LOOP)
if (allocated (object%i_virt)) then
object%i_virt(flv_index(i_proc), i_hel) = label(i_proc)
else
call msg_fatal ("Loop matrix element present, &
&but virt-indices are not allocated!")
end if
case default
call msg_fatal ("Undefined amplitude type")
end select
if (allocated (object%i_hel)) &
object%i_hel (i_proc, :) = helicities (label(i_proc), :)
end do
end subroutine prc_blha_read_contract_file
@ %def prc_blha_read_contract_file
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: print_parameter_file => prc_blha_print_parameter_file
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_print_parameter_file (object, i_component)
class(prc_blha_t), intent(in) :: object
integer, intent(in) :: i_component
end subroutine prc_blha_print_parameter_file
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_print_parameter_file (object, i_component)
class(prc_blha_t), intent(in) :: object
integer, intent(in) :: i_component
type(string_t) :: filename
select type (def => object%def)
class is (blha_def_t)
filename = def%basename // '_' // str (i_component) // '.olp_parameters'
end select
select type (driver => object%driver)
class is (blha_driver_t)
call driver%blha_olp_print_parameter (char(filename)//c_null_char)
end select
end subroutine prc_blha_print_parameter_file
@ %def prc_blha_print_parameter_file
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: compute_amplitude => prc_blha_compute_amplitude
<<BLHA OLP interfaces: sub interfaces>>=
module function prc_blha_compute_amplitude &
(object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, &
core_state) result (amp)
class(prc_blha_t), intent(in) :: object
integer, intent(in) :: j
type(vector4_t), dimension(:), intent(in) :: p
integer, intent(in) :: f, h, c
real(default), intent(in) :: fac_scale, ren_scale
real(default), intent(in), allocatable :: alpha_qcd_forced
class(prc_core_state_t), intent(inout), allocatable, optional :: core_state
complex(default) :: amp
end function prc_blha_compute_amplitude
<<BLHA OLP interfaces: procedures>>=
module function prc_blha_compute_amplitude &
(object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, &
core_state) result (amp)
class(prc_blha_t), intent(in) :: object
integer, intent(in) :: j
type(vector4_t), dimension(:), intent(in) :: p
integer, intent(in) :: f, h, c
real(default), intent(in) :: fac_scale, ren_scale
real(default), intent(in), allocatable :: alpha_qcd_forced
class(prc_core_state_t), intent(inout), allocatable, optional :: core_state
complex(default) :: amp
select type (core_state)
class is (blha_state_t)
core_state%alpha_qcd = object%qcd%alpha%get (ren_scale)
end select
amp = zero
end function prc_blha_compute_amplitude
@ %def prc_blha_compute_amplitude
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: init_blha => prc_blha_init_blha
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_init_blha (object, blha_template, n_in, &
n_particles, n_flv, n_hel)
class(prc_blha_t), intent(inout) :: object
type(blha_template_t), intent(in) :: blha_template
integer, intent(in) :: n_in, n_particles, n_flv, n_hel
end subroutine prc_blha_init_blha
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_init_blha (object, blha_template, n_in, &
n_particles, n_flv, n_hel)
class(prc_blha_t), intent(inout) :: object
type(blha_template_t), intent(in) :: blha_template
integer, intent(in) :: n_in, n_particles, n_flv, n_hel
object%n_particles = n_particles
object%n_flv = n_flv
object%n_hel = n_hel
if (blha_template%compute_loop ()) then
if (blha_template%include_polarizations) then
allocate (object%i_virt (n_flv, n_hel), &
object%i_color_c (n_flv, n_hel))
if (blha_template%use_internal_color_correlations) then
allocate (object%i_hel (n_flv * n_in * n_hel * 2, n_in))
else
allocate (object%i_hel (n_flv * n_in * n_hel, n_in))
end if
else
allocate (object%i_virt (n_flv, 1), object%i_color_c (n_flv, 1))
end if
object%i_virt = -1
object%i_color_c = -1
else if (blha_template%compute_subtraction ()) then
if (blha_template%include_polarizations) then
allocate (object%i_tree (n_flv, n_hel), &
object%i_color_c (n_flv, n_hel), &
object%i_spin_c (n_flv, n_hel), &
object%i_hel (3 * (n_flv * n_hel * n_in), n_in))
object%i_hel = 0
else
allocate (object%i_tree (n_flv, 1), object%i_color_c (n_flv, 1) , &
object%i_spin_c (n_flv, 1))
end if
object%i_tree = -1
object%i_color_c = -1
object%i_spin_c = -1
else if (blha_template%compute_dglap ()) then
if (blha_template%include_polarizations) then
allocate (object%i_tree (n_flv, n_hel), &
object%i_color_c (n_flv, n_hel), &
object%i_hel (3 * (n_flv * n_hel * n_in), n_in))
object%i_hel = 0
else
allocate (object%i_tree (n_flv, 1), object%i_color_c (n_flv, 1))
end if
object%i_tree = -1
object%i_color_c = -1
else if (blha_template%compute_real_trees () .or. blha_template%compute_born ()) then
if (blha_template%include_polarizations) then
allocate (object%i_tree (n_flv, n_hel))
allocate (object%i_hel (n_flv * n_hel * n_in, n_in))
object%i_hel = 0
else
allocate (object%i_tree (n_flv, 1))
end if
object%i_tree = -1
end if
call object%init_ew_parameters (blha_template%ew_scheme)
select type (driver => object%driver)
class is (blha_driver_t)
driver%include_polarizations = blha_template%include_polarizations
driver%switch_off_muon_yukawas = blha_template%switch_off_muon_yukawas
driver%external_top_yukawa = blha_template%external_top_yukawa
end select
end subroutine prc_blha_init_blha
@ %def prc_blha_init_blha
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: set_mass_and_width => prc_blha_set_mass_and_width
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_set_mass_and_width (object, i_pdg, mass, width)
class(prc_blha_t), intent(inout) :: object
integer, intent(in) :: i_pdg
real(default), intent(in) :: mass, width
end subroutine prc_blha_set_mass_and_width
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_set_mass_and_width (object, i_pdg, mass, width)
class(prc_blha_t), intent(inout) :: object
integer, intent(in) :: i_pdg
real(default), intent(in) :: mass, width
select type (driver => object%driver)
class is (blha_driver_t)
call driver%set_mass_and_width (i_pdg, mass, width)
end select
end subroutine prc_blha_set_mass_and_width
@ %def prc_blha_set_mass_and_width
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: set_particle_properties => prc_blha_set_particle_properties
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_set_particle_properties (object, model)
class(prc_blha_t), intent(inout) :: object
class(model_data_t), intent(in), target :: model
end subroutine prc_blha_set_particle_properties
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_set_particle_properties (object, model)
class(prc_blha_t), intent(inout) :: object
class(model_data_t), intent(in), target :: model
integer :: i, i_pdg
type(flavor_t) :: flv
real(default) :: mass, width
integer :: ierr
real(default) :: top_yukawa
do i = 1, OLP_N_MASSIVE_PARTICLES
i_pdg = OLP_MASSIVE_PARTICLES(i)
if (i_pdg < 0) cycle
call flv%init (i_pdg, model)
mass = flv%get_mass (); width = flv%get_width ()
select type (driver => object%driver)
class is (blha_driver_t)
call driver%set_mass_and_width (i_pdg, mass = mass, width = width)
if (i_pdg == 5) call driver%blha_olp_set_parameter &
('yuk(5)'//c_null_char, dble(mass), 0._double, ierr)
if (i_pdg == 6) then
if (driver%external_top_yukawa > 0._default) then
top_yukawa = driver%external_top_yukawa
else
top_yukawa = mass
end if
call driver%blha_olp_set_parameter &
('yuk(6)'//c_null_char, dble(top_yukawa), 0._double, ierr)
end if
if (driver%switch_off_muon_yukawas) then
if (i_pdg == 13) call driver%blha_olp_set_parameter &
('yuk(13)' //c_null_char, 0._double, 0._double, ierr)
end if
end select
end do
end subroutine prc_blha_set_particle_properties
@ %def prc_blha_set_particle_properties
@ This mask adapts which electroweak parameters are supposed to set according to
the chosen BLHA EWScheme. This is only implemented for the default OLP method so far.
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: init_ew_parameters => prc_blha_init_ew_parameters
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_init_ew_parameters (object, ew_scheme)
class(prc_blha_t), intent(inout) :: object
integer, intent(in) :: ew_scheme
end subroutine prc_blha_init_ew_parameters
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_init_ew_parameters (object, ew_scheme)
class(prc_blha_t), intent(inout) :: object
integer, intent(in) :: ew_scheme
object%ew_parameter_mask = .false.
select case (ew_scheme)
case (BLHA_EW_0)
object%ew_parameter_mask (I_ALPHA_0) = .true.
case (BLHA_EW_GF)
object%ew_parameter_mask (I_GF) = .true.
case (BLHA_EW_MZ)
object%ew_parameter_mask (I_ALPHA_MZ) = .true.
case (BLHA_EW_INTERNAL)
object%ew_parameter_mask (I_ALPHA_INTERNAL) = .true.
end select
end subroutine prc_blha_init_ew_parameters
@ %def prc_blha_init_ew_parameters
@ Computes a virtual matrix element from an interface to an
external one-loop provider. The output of [[blha_olp_eval2]]
is an array of [[dimension(4)]], corresponding to the
$\epsilon^2$-, $\epsilon^1$- and $\epsilon^0$-poles of the
virtual matrix element at position [[r(1:3)]] and the Born
matrix element at position [[r(4)]]. The matrix element is
rejected if its accuracy is larger than the maximal allowed
accuracy. OpenLoops includes a factor of 1 / [[n_hel]] in the
amplitudes, which we have to undo if polarized matrix elements
are requested (GoSam does not support polarized matrix elements).
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: compute_sqme_virt => prc_blha_compute_sqme_virt
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_compute_sqme_virt (object, &
i_flv, i_hel, p, ren_scale, es_scale, loop_method, sqme, bad_point)
class(prc_blha_t), intent(in) :: object
integer, intent(in) :: i_flv, i_hel
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: ren_scale, es_scale
integer, intent(in) :: loop_method
real(default), dimension(4), intent(out) :: sqme
logical, intent(out) :: bad_point
end subroutine prc_blha_compute_sqme_virt
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_compute_sqme_virt (object, &
i_flv, i_hel, p, ren_scale, es_scale, loop_method, sqme, bad_point)
class(prc_blha_t), intent(in) :: object
integer, intent(in) :: i_flv, i_hel
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: ren_scale, es_scale
integer, intent(in) :: loop_method
real(default), dimension(4), intent(out) :: sqme
logical, intent(out) :: bad_point
real(double), dimension(5 * object%n_particles) :: mom
real(double), dimension(:), allocatable :: r
real(double) :: mu_dble, es_dble
real(double) :: acc_dble
real(default) :: acc
real(default) :: alpha_s
integer :: ierr
if (object%i_virt(i_flv, i_hel) >= 0) then
allocate (r (blha_result_array_size (object%n_particles, BLHA_AMP_LOOP)))
if (debug_on) call msg_debug2 (D_VIRTUAL, "prc_blha_compute_sqme_virt")
if (debug_on) call msg_debug2 (D_VIRTUAL, "i_flv", i_flv)
if (debug_on) call msg_debug2 (D_VIRTUAL, "object%i_virt(i_flv, i_hel)", object%i_virt(i_flv, i_hel))
if (debug2_active (D_VIRTUAL)) then
call msg_debug2 (D_VIRTUAL, "use momenta: ")
call vector4_write_set (p, show_mass = .true., &
check_conservation = .true.)
end if
mom = object%create_momentum_array (p)
if (vanishes (ren_scale)) &
call msg_fatal ("prc_blha_compute_sqme_virt: ren_scale vanishes")
mu_dble = dble (ren_scale)
es_dble = dble (es_scale)
alpha_s = object%qcd%alpha%get (ren_scale)
select type (driver => object%driver)
class is (blha_driver_t)
if (loop_method == BLHA_MODE_OPENLOOPS) then
call driver%blha_olp_set_parameter ('mureg'//c_null_char, es_dble, 0._double, ierr)
if (ierr == 0) call parameter_error_message (var_str ('mureg'), &
var_str ('prc_blha_compute_sqme_virt'))
end if
call driver%set_alpha_s (alpha_s)
call driver%blha_olp_eval2 (object%i_virt(i_flv, i_hel), mom, mu_dble, r, acc_dble)
end select
acc = acc_dble
sqme = r(1:4)
bad_point = acc > object%maximum_accuracy
if (object%includes_polarization ()) sqme = object%n_hel * sqme
else
sqme = zero
end if
end subroutine prc_blha_compute_sqme_virt
@ %def prc_blha_compute_sqme_virt
@ Computes a tree-level matrix element from an interface to an
external one-loop provider. The matrix element is
rejected if its accuracy is larger than the maximal allowed
accuracy. OpenLoops includes a factor of 1 / [[n_hel]] in the
amplitudes, which we have to undo if polarized matrix elements
are requested (GoSam does not support polarized matrix elements).
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: compute_sqme => prc_blha_compute_sqme
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_compute_sqme (object, i_flv, i_hel, p, &
ren_scale, sqme, bad_point)
class(prc_blha_t), intent(in) :: object
integer, intent(in) :: i_flv, i_hel
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: ren_scale
real(default), intent(out) :: sqme
logical, intent(out) :: bad_point
end subroutine prc_blha_compute_sqme
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_compute_sqme (object, i_flv, i_hel, p, &
ren_scale, sqme, bad_point)
class(prc_blha_t), intent(in) :: object
integer, intent(in) :: i_flv, i_hel
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: ren_scale
real(default), intent(out) :: sqme
logical, intent(out) :: bad_point
real(double), dimension(5*object%n_particles) :: mom
real(double), dimension(OLP_RESULTS_LIMIT) :: r
real(double) :: mu_dble, acc_dble
real(default) :: acc, alpha_s
if (object%i_tree(i_flv, i_hel) >= 0) then
if (debug_on) call msg_debug2 (D_REAL, "prc_blha_compute_sqme")
if (debug_on) call msg_debug2 (D_REAL, "i_flv", i_flv)
if (debug2_active (D_REAL)) then
call msg_debug2 (D_REAL, "use momenta: ")
call vector4_write_set (p, show_mass = .true., &
check_conservation = .true.)
end if
mom = object%create_momentum_array (p)
if (vanishes (ren_scale)) &
call msg_fatal ("prc_blha_compute_sqme: ren_scale vanishes")
mu_dble = dble(ren_scale)
alpha_s = object%qcd%alpha%get (ren_scale)
select type (driver => object%driver)
class is (blha_driver_t)
call driver%set_alpha_s (alpha_s)
call driver%blha_olp_eval2 (object%i_tree(i_flv, i_hel), mom, &
mu_dble, r, acc_dble)
sqme = r(object%sqme_tree_pos)
end select
acc = acc_dble
bad_point = acc > object%maximum_accuracy
if (object%includes_polarization ()) sqme = object%n_hel * sqme
else
sqme = zero
end if
end subroutine prc_blha_compute_sqme
@ %def prc_blha_compute_sqme
@
For the color correlated matrix the standard is to compute the diagonal entries
from the born amplitudes and corresponding casimirs. However, if EW
corrections are activated, the thus derived entries can be computed with born
amplitudes of wrong coupling powers if the flavor structure potentially induces
QCD-EW interference amplitudes. For this purpose a second possibility, to
compute the diagonal from the off-diagonal elements is implemented as a special
case.
<<BLHA OLP interfaces: public>>=
public :: blha_color_c_fill_diag
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine blha_color_c_fill_diag &
(sqme_born, flavors, sqme_color_c, special_case)
real(default), intent(in) :: sqme_born
integer, intent(in), dimension(:) :: flavors
logical, intent(in), optional :: special_case
real(default), intent(inout), dimension(:,:) :: sqme_color_c
end subroutine blha_color_c_fill_diag
<<BLHA OLP interfaces: procedures>>=
module subroutine blha_color_c_fill_diag &
(sqme_born, flavors, sqme_color_c, special_case)
real(default), intent(in) :: sqme_born
integer, intent(in), dimension(:) :: flavors
logical, intent(in), optional :: special_case
real(default), intent(inout), dimension(:,:) :: sqme_color_c
real(default) :: sqme_line_off
integer :: i, j
logical :: special_c
special_c = .false.
if (present (special_case)) &
special_c = special_case .and. qcd_ew_interferences (flavors)
do i = 1, size (flavors)
if (is_quark (flavors(i))) then
sqme_line_off = zero
do j = 1, size (flavors)
if (j /= i) sqme_line_off = sqme_line_off + sqme_color_c (i, j)
end do
if (special_c) then
sqme_color_c (i, i) = - sqme_line_off
else
sqme_color_c (i, i) = -cf * sqme_born
end if
else if (is_gluon (flavors(i))) then
sqme_line_off = zero
do j = 1, size (flavors)
if (j /= i) sqme_line_off = sqme_line_off + sqme_color_c (i, j)
end do
if (special_c) then
sqme_color_c (i, i) = - sqme_line_off
else
sqme_color_c (i, i) = -ca * sqme_born
end if
else
sqme_color_c (i, i) = zero
end if
end do
end subroutine blha_color_c_fill_diag
@ %def blha_color_c_fill_diag
<<BLHA OLP interfaces: public>>=
public :: blha_color_c_fill_offdiag
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine blha_color_c_fill_offdiag &
(n, r, sqme_color_c, offset, n_flv)
integer, intent(in) :: n
real(default), intent(in), dimension(:) :: r
real(default), intent(inout), dimension(:,:) :: sqme_color_c
integer, intent(in), optional :: offset, n_flv
end subroutine blha_color_c_fill_offdiag
<<BLHA OLP interfaces: procedures>>=
module subroutine blha_color_c_fill_offdiag &
(n, r, sqme_color_c, offset, n_flv)
integer, intent(in) :: n
real(default), intent(in), dimension(:) :: r
real(default), intent(inout), dimension(:,:) :: sqme_color_c
integer, intent(in), optional :: offset, n_flv
integer :: i, j, pos, incr
if (present (offset)) then
incr = offset
else
incr = 0
end if
pos = 0
do j = 1, n
do i = 1, j
if (i /= j) then
pos = (j - 1) * (j - 2) / 2 + i
if (present (n_flv)) incr = incr + n_flv - 1
if (present (offset)) pos = pos + incr
sqme_color_c (i, j) = -r (pos)
sqme_color_c (j, i) = sqme_color_c (i, j)
end if
end do
end do
end subroutine blha_color_c_fill_offdiag
@ %def blha_color_c_fill_offdiag
@ Computes a color-correlated matrix element from an interface to an
external one-loop provider. The output of [[blha_olp_eval2]] is
an array of [[dimension(n * (n - 1) / 2)]]. The matrix element is
rejected if its accuracy is larger than the maximal allowed
accuracy. OpenLoops includes a factor of 1 / [[n_hel]] in the
amplitudes, which we have to undo if polarized matrix elements
are requested (GoSam does not support polarized matrix elements).
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: compute_sqme_color_c_raw => prc_blha_compute_sqme_color_c_raw
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_compute_sqme_color_c_raw &
(object, i_flv, i_hel, p, ren_scale, rr, bad_point)
class(prc_blha_t), intent(in) :: object
integer, intent(in) :: i_flv, i_hel
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: ren_scale
real(default), intent(out), dimension(:) :: rr
logical, intent(out) :: bad_point
end subroutine prc_blha_compute_sqme_color_c_raw
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_compute_sqme_color_c_raw &
(object, i_flv, i_hel, p, ren_scale, rr, bad_point)
class(prc_blha_t), intent(in) :: object
integer, intent(in) :: i_flv, i_hel
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: ren_scale
real(default), intent(out), dimension(:) :: rr
logical, intent(out) :: bad_point
real(double), dimension(5 * object%n_particles) :: mom
real(double), dimension(size(rr)) :: r
real(default) :: alpha_s, acc
real(double) :: mu_dble, acc_dble
if (debug2_active (D_REAL)) then
call msg_debug2 (D_REAL, "use momenta: ")
call vector4_write_set (p, show_mass = .true., &
check_conservation = .true.)
end if
if (object%i_color_c(i_flv, i_hel) >= 0) then
mom = object%create_momentum_array (p)
if (vanishes (ren_scale)) &
call msg_fatal ("prc_blha_compute_sqme_color_c: ren_scale vanishes")
mu_dble = dble(ren_scale)
alpha_s = object%qcd%alpha%get (ren_scale)
select type (driver => object%driver)
class is (blha_driver_t)
call driver%set_alpha_s (alpha_s)
call driver%blha_olp_eval2 (object%i_color_c(i_flv, i_hel), &
mom, mu_dble, r, acc_dble)
end select
rr = r
acc = acc_dble
bad_point = acc > object%maximum_accuracy
if (object%includes_polarization ()) rr = object%n_hel * rr
else
rr = zero
end if
end subroutine prc_blha_compute_sqme_color_c_raw
@ %def prc_blha_compute_sqme_color_c_raw
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: compute_sqme_color_c => prc_blha_compute_sqme_color_c
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_compute_sqme_color_c &
(object, i_flv, i_hel, p, ren_scale, born_color_c, bad_point, born_out)
class(prc_blha_t), intent(inout) :: object
integer, intent(in) :: i_flv, i_hel
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: ren_scale
real(default), intent(inout), dimension(:,:) :: born_color_c
real(default), intent(out), optional :: born_out
logical, intent(out) :: bad_point
end subroutine prc_blha_compute_sqme_color_c
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_compute_sqme_color_c &
(object, i_flv, i_hel, p, ren_scale, born_color_c, bad_point, born_out)
class(prc_blha_t), intent(inout) :: object
integer, intent(in) :: i_flv, i_hel
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: ren_scale
real(default), intent(inout), dimension(:,:) :: born_color_c
real(default), intent(out), optional :: born_out
logical, intent(out) :: bad_point
real(default), dimension(:), allocatable :: r
logical :: bad_point2
real(default) :: born
integer, dimension(:), allocatable :: flavors
if (debug2_active (D_REAL)) then
call msg_debug2 (D_REAL, "use momenta: ")
call vector4_write_set (p, show_mass = .true., &
check_conservation = .true.)
end if
allocate (r (blha_result_array_size &
(size(born_color_c, dim=1), BLHA_AMP_COLOR_C)))
call object%compute_sqme_color_c_raw (i_flv, i_hel, p, ren_scale, r, bad_point)
select type (driver => object%driver)
class is (blha_driver_t)
if (allocated (object%i_tree)) then
call object%compute_sqme (i_flv, i_hel, p, ren_scale, born, bad_point2)
else
born = zero
end if
if (present (born_out)) born_out = born
end select
call blha_color_c_fill_offdiag (object%n_particles, r, born_color_c)
flavors = object%get_flv_state (i_flv)
call blha_color_c_fill_diag (born, flavors, born_color_c)
bad_point = bad_point .or. bad_point2
end subroutine prc_blha_compute_sqme_color_c
@ %def prc_blha_compute_sqme_color_c
@
<<BLHA OLP interfaces: prc blha: TBP>>=
generic :: get_beam_helicities => get_beam_helicities_single
generic :: get_beam_helicities => get_beam_helicities_array
procedure :: get_beam_helicities_single => prc_blha_get_beam_helicities_single
procedure :: get_beam_helicities_array => prc_blha_get_beam_helicities_array
<<BLHA OLP interfaces: sub interfaces>>=
module function prc_blha_get_beam_helicities_single &
(object, i, invert_second) result (hel)
integer, dimension(:), allocatable :: hel
class(prc_blha_t), intent(in) :: object
logical, intent(in), optional :: invert_second
integer, intent(in) :: i
end function prc_blha_get_beam_helicities_single
module function prc_blha_get_beam_helicities_array &
(object, invert_second) result (hel)
integer, dimension(:,:), allocatable :: hel
class(prc_blha_t), intent(in) :: object
logical, intent(in), optional :: invert_second
end function prc_blha_get_beam_helicities_array
<<BLHA OLP interfaces: procedures>>=
module function prc_blha_get_beam_helicities_single &
(object, i, invert_second) result (hel)
integer, dimension(:), allocatable :: hel
class(prc_blha_t), intent(in) :: object
logical, intent(in), optional :: invert_second
integer, intent(in) :: i
logical :: inv
inv = .false.; if (present (invert_second)) inv = invert_second
allocate (hel (object%data%n_in))
hel = object%i_hel (i, :)
if (inv .and. object%data%n_in == 2) hel(2) = -hel(2)
end function prc_blha_get_beam_helicities_single
@ %def prc_blha_get_beam_helicities_single
@
<<BLHA OLP interfaces: procedures>>=
module function prc_blha_get_beam_helicities_array &
(object, invert_second) result (hel)
integer, dimension(:,:), allocatable :: hel
class(prc_blha_t), intent(in) :: object
logical, intent(in), optional :: invert_second
integer :: i
allocate (hel (object%n_proc, object%data%n_in))
do i = 1, object%n_proc
hel(i,:) = object%get_beam_helicities (i, invert_second)
end do
end function prc_blha_get_beam_helicities_array
@ %def prc_blha_get_beam_helicities_array
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: includes_polarization => prc_blha_includes_polarization
<<BLHA OLP interfaces: sub interfaces>>=
module function prc_blha_includes_polarization (object) result (polarized)
logical :: polarized
class(prc_blha_t), intent(in) :: object
end function prc_blha_includes_polarization
<<BLHA OLP interfaces: procedures>>=
module function prc_blha_includes_polarization (object) result (polarized)
logical :: polarized
class(prc_blha_t), intent(in) :: object
select type (driver => object%driver)
class is (blha_driver_t)
polarized = driver%include_polarizations
end select
end function prc_blha_includes_polarization
@ %def prc_blha_includes_polarization
@ Setup an index mapping for flavor structures and helicities that give the same matrix
element. The index mapping is according to the order of flavor structures known to the
[[prc_core]] class. Overrides [[prc_core_set_equivalent_flv_hel_indices]].
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure :: set_equivalent_flv_hel_indices => prc_blha_set_equivalent_flv_hel_indices
<<BLHA OLP interfaces: sub interfaces>>=
module subroutine prc_blha_set_equivalent_flv_hel_indices (object)
class(prc_blha_t), intent(inout) :: object
end subroutine prc_blha_set_equivalent_flv_hel_indices
<<BLHA OLP interfaces: procedures>>=
module subroutine prc_blha_set_equivalent_flv_hel_indices (object)
class(prc_blha_t), intent(inout) :: object
integer :: n_flv, n_hel
integer :: i_flv1, i_flv2, i_hel1, i_hel2
integer, dimension(:,:), allocatable :: amp_id, amp_id_color
if (allocated (object%i_virt)) then
amp_id = object%i_virt
else
amp_id = object%i_tree
end if
if (allocated (object%i_color_c)) then
amp_id_color = object%i_color_c
end if
n_flv = size (amp_id, dim=1)
n_hel = size (amp_id, dim=2)
if (.not. allocated (object%data%eqv_flv_index)) &
allocate (object%data%eqv_flv_index(n_flv))
if (.not. allocated (object%data%eqv_hel_index)) &
allocate (object%data%eqv_hel_index(n_hel))
if (size (object%data%eqv_flv_index) /= n_flv) &
call msg_bug ("BLHA Core: Size mismatch between eqv_flv_index and number of flavors.")
if (size (object%data%eqv_hel_index) /= n_hel) &
call msg_bug ("BLHA Core: Size mismatch between eqv_hel_index and number of helicities.")
do i_flv1 = 1, n_flv
do i_hel1 = 1, n_hel
FLV_LOOP: do i_flv2 = 1, i_flv1
do i_hel2 = 1, i_hel1
if (amp_id(i_flv2, i_hel2) == amp_id(i_flv1, i_hel1)) then
if (.not. allocated (amp_id_color)) then
object%data%eqv_flv_index(i_flv1) = i_flv2
object%data%eqv_hel_index(i_hel1) = i_hel2
exit FLV_LOOP
else if (amp_id_color (i_flv2, i_hel2) == &
amp_id_color(i_flv1, i_hel1)) then
object%data%eqv_flv_index(i_flv1) = i_flv2
object%data%eqv_hel_index(i_hel1) = i_hel2
exit FLV_LOOP
end if
end if
end do
end do FLV_LOOP
end do
end do
end subroutine prc_blha_set_equivalent_flv_hel_indices
@ %def prc_blha_set_equivalent_flv_hel_indices
@
<<BLHA OLP interfaces: prc blha: TBP>>=
procedure(prc_blha_init_driver), deferred :: &
init_driver
<<BLHA OLP interfaces: interfaces>>=
abstract interface
subroutine prc_blha_init_driver (object, os_data)
import
class(prc_blha_t), intent(inout) :: object
type(os_data_t), intent(in) :: os_data
end subroutine prc_blha_init_driver
end interface
@ %def prc_blha_init_driver interface
-@ In general, the BLHA consits of a virtual matrix element and $n_{\rm{sub}}$
+@ In general, the BLHA consists of a virtual matrix element and $n_{\rm{sub}}$
subtraction terms. The subtractions terms can be pure Born matrix elements
(to be used in collinear subtraction or in internal color-correlation),
color-correlated matrix elements or spin-correlated matrix elements.
The numbers should be ordered in such a way that $\mathcal{V}_{\rm{fin}}$
is first, followed by the pure Born, the color-correlated and the spin-correlated
matrix elements. This repeats $n_{\rm{flv}}$ times. Let $\nu_i$ be the position
-of the $ith$ virtual matrix element. The next $\mathcal{V}_{\rm{fin}}$ is
+of the $i$th virtual matrix element. The next $\mathcal{V}_{\rm{fin}}$ is
at position $\nu_i = \nu_{i - 1} + n_{\rm{sub}} + 1$. Obviously, $\nu_1 = 1$.
This allows us to determine the virtual matrix element positions using the
recursive function implemented below.
<<BLHA OLP interfaces: public>>=
public :: blha_loop_positions
<<BLHA OLP interfaces: sub interfaces>>=
recursive module function blha_loop_positions (i_flv, n_sub) result (index)
integer :: index
integer, intent(in) :: i_flv, n_sub
end function blha_loop_positions
<<BLHA OLP interfaces: procedures>>=
recursive module function blha_loop_positions (i_flv, n_sub) result (index)
integer :: index
integer, intent(in) :: i_flv, n_sub
index = 0
if (i_flv == 1) then
index = 1
else
index = blha_loop_positions (i_flv - 1, n_sub) + n_sub + 1
end if
end function blha_loop_positions
@ %def blha_loop_positions
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[blha_ut.f90]]>>=
<<File header>>
module blha_ut
use unit_tests
use blha_uti
<<Standard module head>>
<<BLHA: public tests>>
contains
<<BLHA: test driver>>
end module blha_ut
@ %def blha_ut
@
<<[[blha_uti.f90]]>>=
<<File header>>
module blha_uti
<<Use strings>>
use format_utils, only: write_separator
use variables, only: var_list_t
use os_interface
use models
use blha_config
<<Standard module head>>
<<BLHA: test declarations>>
contains
<<BLHA: test procedures>>
<<BLHA: tests>>
end module blha_uti
@ %def blha_uti
@ API: driver for the unit tests below.
<<BLHA: public tests>>=
public :: blha_test
<<BLHA: test driver>>=
subroutine blha_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
call test(blha_1, "blha_1", "Test the creation of BLHA-OLP files", u, results)
call test(blha_2, "blha_2", "Test the creation of BLHA-OLP files for "&
&"multiple flavor structures", u, results)
call test(blha_3, "blha_3", "Test helicity-information in OpenLoops OLP files", &
u, results)
end subroutine blha_test
@ %def blha_test
@
<<BLHA: test procedures>>=
subroutine setup_and_write_blha_configuration (u, single, polarized)
integer, intent(in) :: u
logical, intent(in), optional :: single
logical, intent(in), optional :: polarized
logical :: polrzd, singl
type(blha_master_t) :: blha_master
integer :: i
integer :: n_in, n_out
integer :: alpha_power, alphas_power
integer, dimension(:,:), allocatable :: flv_born, flv_real
type(string_t) :: proc_id, method, correction_type
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(var_list_t) :: var_list
type(model_t), pointer :: model => null ()
integer :: openloops_phs_tolerance
polrzd = .false.; if (present (polarized)) polrzd = polarized
singl = .true.; if (present (single)) singl = single
if (singl) then
write (u, "(A)") "* Process: e+ e- -> W+ W- b b~"
n_in = 2; n_out = 4
alpha_power = 4; alphas_power = 0
allocate (flv_born (n_in + n_out, 1))
allocate (flv_real (n_in + n_out + 1, 1))
flv_born(1,1) = 11; flv_born(2,1) = -11
flv_born(3,1) = 24; flv_born(4,1) = -24
flv_born(5,1) = 5; flv_born(6,1) = -5
flv_real(1:6,1) = flv_born(:,1)
flv_real(7,1) = 21
else
write (u, "(A)") "* Process: e+ e- -> u:d:s U:D:S"
n_in = 2; n_out = 2
alpha_power = 2; alphas_power = 0
allocate (flv_born (n_in + n_out, 3))
allocate (flv_real (n_in + n_out + 1, 3))
flv_born(1,:) = 11; flv_born(2,:) = -11
flv_born(3,1) = 1; flv_born(4,1) = -1
flv_born(3,2) = 2; flv_born(4,2) = -2
flv_born(3,3) = 3; flv_born(4,3) = -3
flv_real(1:4,:) = flv_born
flv_real(5,:) = 21
end if
proc_id = var_str ("BLHA_Test")
call syntax_model_file_init ()
call os_data%init ()
call model_list%read_model &
(var_str ("SM"), var_str ("SM.mdl"), os_data, model)
write (u, "(A)") "* BLHA matrix elements assumed for all process components"
write (u, "(A)") "* Mode: GoSam"
method = var_str ("gosam")
correction_type = var_str ("QCD")
call var_list%append_string (var_str ("$born_me_method"), method)
call var_list%append_string (var_str ("$real_tree_me_method"), method)
call var_list%append_string (var_str ("$loop_me_method"), method)
call var_list%append_string (var_str ("$correlation_me_method"), method)
call blha_master%set_ew_scheme (var_str ("GF"))
call blha_master%set_methods (.true., var_list)
call blha_master%allocate_config_files ()
call blha_master%set_correction_type (correction_type)
call blha_master%generate (proc_id, model, n_in, &
alpha_power, alphas_power, flv_born, flv_real)
call test_output (u)
call blha_master%final ()
call var_list%final ()
write (u, "(A)") "* Switch to OpenLoops"
openloops_phs_tolerance = 7
method = var_str ("openloops")
correction_type = var_str ("QCD")
call var_list%append_string (var_str ("$born_me_method"), method)
call var_list%append_string (var_str ("$real_tree_me_method"), method)
call var_list%append_string (var_str ("$loop_me_method"), method)
call var_list%append_string (var_str ("$correlation_me_method"), method)
call blha_master%set_methods (.true., var_list)
call blha_master%allocate_config_files ()
call blha_master%set_correction_type (correction_type)
call blha_master%generate (proc_id, model, n_in, &
alpha_power, alphas_power, flv_born, flv_real)
if (polrzd) then
do i = 1, 4
call blha_master%set_polarization (i)
end do
end if
call blha_master%setup_additional_features &
(openloops_phs_tolerance, .false., 0)
call test_output (u)
contains
subroutine test_output (u)
integer, intent(in) :: u
do i = 1, 4
call write_separator (u)
call write_component_type (i, u)
call write_separator (u)
call blha_configuration_write &
(blha_master%blha_cfg(i), blha_master%suffix(i), u, no_version = .true.)
end do
end subroutine test_output
subroutine write_component_type (i, u)
integer, intent(in) :: i, u
type(string_t) :: message, component_type
message = var_str ("OLP-File content for ")
select case (i)
case (1)
component_type = var_str ("loop")
case (2)
component_type = var_str ("subtraction")
case (3)
component_type = var_str ("real")
case (4)
component_type = var_str ("born")
end select
message = message // component_type // " matrix elements"
write (u, "(A)") char (message)
end subroutine write_component_type
end subroutine setup_and_write_blha_configuration
@ %def setup_and_write_blha_configuration
@
<<BLHA: test declarations>>=
public :: blha_1
<<BLHA: tests>>=
subroutine blha_1 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: blha_1"
write (u, "(A)") "* Purpose: Test the creation of olp-files for single "&
&"and unpolarized flavor structures"
write (u, "(A)")
call setup_and_write_blha_configuration (u, single = .true., polarized = .false.)
end subroutine blha_1
@ %def blha_1
@
<<BLHA: test declarations>>=
public :: blha_2
<<BLHA: tests>>=
subroutine blha_2 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: blha_2"
write (u, "(A)") "* Purpose: Test the creation of olp-files for multiple "&
&"and unpolarized flavor structures"
write (u, "(A)")
call setup_and_write_blha_configuration (u, single = .false., polarized = .false.)
end subroutine blha_2
@ %def blha_2
@
<<BLHA: test declarations>>=
public :: blha_3
<<BLHA: tests>>=
subroutine blha_3 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: blha_3"
write (u, "(A)") "* Purpose: Test the creation of olp-files for single "&
&"and polarized flavor structures"
write (u, "(A)")
call setup_and_write_blha_configuration (u, single = .true., polarized = .true.)
end subroutine blha_3
@ %def blha_3
@
Index: trunk/src/variables/variables.nw
===================================================================
--- trunk/src/variables/variables.nw (revision 8842)
+++ trunk/src/variables/variables.nw (revision 8843)
@@ -1,7763 +1,7763 @@
% -*- 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]]>>=
<<File header>>
module variables
<<Use kinds>>
<<Use strings>>
use numeric_utils, only: pacify
use os_interface, only: paths_t
use pdg_arrays
use subevents
use var_base
<<Standard module head>>
<<Variables: public>>
<<Variables: parameters>>
<<Variables: types>>
<<Variables: interfaces>>
interface
<<Variables: sub interfaces>>
end interface
end module variables
@ %def variables
@
<<[[variables_sub.f90]]>>=
<<File header>>
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
<<Variables: procedures>>
end submodule variables_s
@ %def variables_s
@
\subsection{Variable list entries}
Variable (and constant) values can be of one of the following types:
<<Variables: parameters>>=
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.
<<Variables: types>>=
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}
<<Variables: public>>=
public :: obs_unary_int
public :: obs_unary_real
public :: obs_binary_int
public :: obs_binary_real
public :: obs_sev_int
public :: obs_sev_real
<<Variables: interfaces>>=
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.
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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}
<<Variables: procedures>>=
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}
<<Variables: procedures>>=
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
@
<<Variables: procedures>>=
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}
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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
<<Variables: procedures>>=
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
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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,
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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
<<Variables: procedures>>=
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
@
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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.
<<Variables: public>>=
public :: var_list_t
<<Variables: types>>=
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
<<Variables: var list: TBP>>
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.
<<Variables: var list: TBP>>=
procedure :: link => var_list_link
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: sort => var_list_sort
<<Variables: sub interfaces>>=
module subroutine var_list_sort (var_list)
class(var_list_t), intent(inout) :: var_list
end subroutine var_list_sort
<<Variables: procedures>>=
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
@
<<Variables: procedures>>=
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
@
<<Variables: var list: TBP>>=
procedure :: get_previous => var_list_get_previous
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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
@
<<Variables: var list: TBP>>=
procedure :: swap_with_next => var_list_swap_with_next
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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)
<<Variables: var list: TBP>>=
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
<<Variables: interfaces>>=
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
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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
<<Variables: var list: TBP>>=
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
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: final => var_list_final
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: write => var_list_write
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: write_var => var_list_write_var
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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
<<Variables: var list: TBP>>=
procedure :: get_type => var_list_get_type
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: contains => var_list_exists
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.)
<<Variables: var list: TBP>>=
procedure :: is_intrinsic => var_list_is_intrinsic
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: is_known => var_list_is_known
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.)
<<Variables: var list: TBP>>=
procedure :: is_locked => var_list_is_locked
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: get_var_properties => var_list_get_var_properties
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
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
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
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
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
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
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: set_procvar_int => var_list_set_procvar_int
procedure :: set_procvar_real => var_list_set_procvar_real
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
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
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: append_uobs_int => var_list_append_uobs_int
procedure :: append_uobs_real => var_list_append_uobs_real
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: unset => var_list_clear
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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):
<<Variables: var list: 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
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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):
<<Variables: var list: TBP>>=
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
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: import => var_list_import
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: undefine => var_list_undefine
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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.
<<Variables: var list: TBP>>=
procedure :: init_snapshot => var_list_init_snapshot
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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]].
<<Variables: var list: TBP>>=
procedure :: check_user_var => var_list_check_user_var
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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}
<<Variables: var list: TBP>>=
procedure :: init_defaults => var_list_init_defaults
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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
@
<<Variables: var list: TBP>>=
procedure :: set_beams_defaults => var_list_set_beams_defaults
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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 ' // &
'<num>} [ {\em <phys\_unit>} ]}. 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 ' // &
'<num>}} 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 ' // &
'<proc\_name>}\_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 <file\_name>}"} ' // &
'allows to change the detailed structure function information ' // &
'switched on by the debug flag ($\to$) \ttt{?sf\_trace} into ' // &
'a different file \ttt{{\em <file\_name>}} than the default ' // &
'\ttt{{\em <proc\_name>}\_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 <pdf\_set>}"} allows to specify the PDF set \ttt{{\em ' // &
'<pdf\_set>}} 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 <pdf\_set>}"} 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\_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\_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\_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
@
<<Variables: var list: TBP>>=
procedure :: set_core_defaults => var_list_set_core_defaults
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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 <num>}} ' // &
'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 <int\_var>}} 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 <process\_name>} = {\em <particle1>}, {\em <particle2>} ' // &
'=> {\em <particle3>}, {\em <particle4>}, ... \{ \$restrictions ' // &
'= "{\em <restriction\_def>}" \}}. The string argument \ttt{{\em ' // &
'<restriction\_def>}} is directly transferred during the code ' // &
'generation to the ME generator \oMega. It has to be of the form ' // &
'\ttt{n1 + n2 + ... \url{~} {\em <particle (list)>}}, 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 <num>}} ' // &
'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 <num>}} ' // &
'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 <num>}} 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 <num>}} 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 <num>}}, 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 <num>}}. 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
@
<<Variables: var list: TBP>>=
procedure :: set_integration_defaults => var_list_set_integration_defaults
<<Variables: sub interfaces>>=
module subroutine var_list_set_integration_defaults (var_list)
class(var_list_t), intent(inout) :: var_list
end subroutine var_list_set_integration_defaults
<<Variables: procedures>>=
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 ' // &
'<id>}"} 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 <proc\_name>}\_{\em <proc\_comp>}.{\em ' // &
'<id>}.log}, the \vamp\ grid file: \newline \ttt{{\em <proc\_name>}\_{\em ' // &
'<proc\_comp>}.{\em <id>}.vg}, and the phase space file: \newline ' // &
'\ttt{{\em <proc\_name>}\_{\em <proc\_comp>}.{\em <id>}.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 <num>}} declares that any error value (in absolute numbers) ' // &
'smaller than \ttt{{\em <num>}} 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
@
<<Variables: var list: TBP>>=
procedure :: set_phase_space_defaults => var_list_set_phase_space_defaults
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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 <file\_name>}"}. ' // &
'If not set, the default is \ttt{{\em <proc\_name>}\_{\em <proc\_comp>}.{\em ' // &
'<run\_id>}.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
@
<<Variables: var list: TBP>>=
procedure :: set_gamelan_defaults => var_list_set_gamelan_defaults
<<Variables: sub interfaces>>=
module subroutine var_list_set_gamelan_defaults (var_list)
class(var_list_t), intent(inout) :: var_list
end subroutine var_list_set_gamelan_defaults
<<Variables: procedures>>=
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 ' // &
'<LaTeX\_Code>}"} 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 ' // &
'<LaTeX\_Code>}"} 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 <your title>}"}. ' // &
'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 ' // &
'<LaTeX analysis descr.>}"}. 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 ' // &
'<LaTeX code>}"}, 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 ' // &
'<LaTeX\_code>}"}, 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 <LaTeX\_code>}"}. (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 <LaTeX\_code>}"}) 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 <LaTeX\_code>}"} 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 <LaTeX\_code>}"} 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 <LaTeX\_code>}"} 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 <LaTeX\_code>}"} 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
<<Variables: var list: TBP>>=
procedure :: set_clustering_defaults => var_list_set_clustering_defaults
<<Variables: sub interfaces>>=
module subroutine var_list_set_clustering_defaults (var_list)
class(var_list_t), intent(inout) :: var_list
end subroutine var_list_set_clustering_defaults
<<Variables: procedures>>=
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:
<<Variables: var list: TBP>>=
procedure :: set_isolation_recomb_defaults => &
var_list_set_isolation_recomb_defaults
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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
<<Variables: var list: TBP>>=
procedure :: set_eio_defaults => var_list_set_eio_defaults
<<Variables: sub interfaces>>=
module subroutine var_list_set_eio_defaults (var_list)
class(var_list_t), intent(inout) :: var_list
end subroutine var_list_set_eio_defaults
<<Variables: procedures>>=
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 <num>}} gives the number \ttt{{\em ' // &
'<num>}} of breakpoints in the event files, i.e. it splits the ' // &
'event files into \ttt{{\em <num>} + 1} parts. The parts are ' // &
'denoted by \ttt{{\em <proc\_name>}.{\em <split\_index>}.{\em ' // &
'<evt\_extension>}}. Here, \ttt{{\em <split\_index>}} is an integer ' // &
'running from \ttt{0} to \ttt{{\em <num>}}. 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 <num>}} 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 <split\_index>}} for ' // &
'the numbering of event samples \ttt{{\em <proc\_name>}.{\em ' // &
'<split\_index>}.{\em <evt\_extension>}} split by the \ttt{sample\_split\_n\_evt ' // &
'= {\em <num>}}. The index runs from \ttt{{\em <split\_index>}} ' // &
'to \newline \ttt{{\em <split\_index>} + {\em <num>}}. (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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.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 <suffix>}"} 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 <process\_name>}.lha.verb}. (cf. also \ttt{sample\_format}, ' // &
'\ttt{\$sample})'))
end subroutine var_list_set_eio_defaults
@ %def var_list_set_eio_defaults
@
<<Variables: var list: TBP>>=
procedure :: set_shower_defaults => var_list_set_shower_defaults
<<Variables: sub interfaces>>=
module subroutine var_list_set_shower_defaults (var_list)
class(var_list_t), intent(inout) :: var_list
end subroutine var_list_set_shower_defaults
<<Variables: procedures>>=
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
@
<<Variables: var list: TBP>>=
procedure :: set_hadronization_defaults => var_list_set_hadronization_defaults
<<Variables: sub interfaces>>=
module subroutine var_list_set_hadronization_defaults (var_list)
class(var_list_t), intent(inout) :: var_list
end subroutine var_list_set_hadronization_defaults
<<Variables: procedures>>=
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
@
<<Variables: var list: TBP>>=
procedure :: set_tauola_defaults => var_list_set_tauola_defaults
<<Variables: sub interfaces>>=
module subroutine var_list_set_tauola_defaults (var_list)
class(var_list_t), intent(inout) :: var_list
end subroutine var_list_set_tauola_defaults
<<Variables: procedures>>=
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
@
<<Variables: var list: TBP>>=
procedure :: set_mlm_matching_defaults => var_list_set_mlm_matching_defaults
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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
@
<<Variables: var list: TBP>>=
procedure :: set_powheg_matching_defaults => &
var_list_set_powheg_matching_defaults
<<Variables: sub interfaces>>=
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
<<Variables: procedures>>=
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"), &
0._default, intrinsic = .true., &
description=var_str ('Reference scale of the $\alpha_s$ evolution ' // &
'in the POWHEG matching algorithm. Per default we use ' // &
'$\Lambda^{n_f=5}_{\overline{MS}}$.' ))
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
@
<<Variables: var list: TBP>>=
procedure :: set_openmp_defaults => var_list_set_openmp_defaults
<<Variables: sub interfaces>>=
module subroutine var_list_set_openmp_defaults (var_list)
class(var_list_t), intent(inout) :: var_list
end subroutine var_list_set_openmp_defaults
<<Variables: procedures>>=
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
@
<<Variables: var list: TBP>>=
procedure :: set_mpi_defaults => var_list_set_mpi_defaults
<<Variables: sub interfaces>>=
module subroutine var_list_set_mpi_defaults (var_list)
class(var_list_t), intent(inout) :: var_list
end subroutine var_list_set_mpi_defaults
<<Variables: procedures>>=
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
@
<<Variables: var list: TBP>>=
procedure :: set_nlo_defaults => var_list_set_nlo_defaults
<<Variables: sub interfaces>>=
module subroutine var_list_set_nlo_defaults (var_list)
class(var_list_t), intent(inout) :: var_list
end subroutine var_list_set_nlo_defaults
<<Variables: procedures>>=
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 = <n>} 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_string (var_str ("$openloops_allowed_libs"), &
var_str (""), intrinsic = .true., &
description=var_str ('String variable to restrict the ' // &
'allowed \openloops process libraries for a process. ' // &
'(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 ' // &
+ 'Here, $\texttt{tiny\_07} = \texttt{1E9\_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 <type>}"} to either ' // &
'\ttt{"QCD"}, \ttt{"EW"}, or to all with \ttt{\em{<type>}} ' // &
'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 <prt1>:<prt2>:\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 <prt>"} 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]]>>=
<<File header>>
module observables
<<Use kinds>>
<<Use strings>>
use subevents
use variables
<<Standard module head>>
<<Observables: public>>
interface
<<Observables: sub interfaces>>
end interface
end module observables
@ %def observables
@
<<[[observables_sub.f90]]>>=
<<File header>>
submodule (observables) observables_s
use io_units
use diagnostics
use lorentz
implicit none
contains
<<Observables: procedures>>
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
<<Observables: procedures>>=
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).
<<Observables: procedures>>=
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.
<<Observables: procedures>>=
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.
<<Observables: procedures>>=
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.
<<Observables: procedures>>=
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
<<Observables: procedures>>=
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)
<<Observables: procedures>>=
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).
<<Observables: procedures>>=
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
<<Observables: procedures>>=
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.
<<Observables: procedures>>=
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.
<<XXX Observables: procedures>>=
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.
<<Observables: procedures>>=
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.
<<Observables: procedures>>=
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.
<<Observables: procedures>>=
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.
<<Observables: procedures>>=
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
<<Observables: procedures>>=
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)
<<Observables: procedures>>=
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).
<<Observables: procedures>>=
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
<<Observables: procedures>>=
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.
<<XXX Observables: procedures>>=
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.
<<Observables: procedures>>=
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.
<<Observables: procedures>>=
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.
<<Observables: procedures>>=
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$.
<<Observables: procedures>>=
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.
<<Observables: public>>=
public :: var_list_init_num_id
<<Observables: sub interfaces>>=
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
<<Observables: procedures>>=
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.
<<Observables: public>>=
public :: var_list_init_process_results
<<Observables: sub interfaces>>=
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
<<Observables: procedures>>=
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.
<<Observables: public>>=
public :: var_list_set_observables_unary
public :: var_list_set_observables_binary
public :: var_list_set_observables_sev
<<Observables: sub interfaces>>=
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
<<Observables: procedures>>=
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}
<<Observables: public>>=
public :: var_list_check_observable
<<Observables: sub interfaces>>=
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
<<Observables: procedures>>=
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:
<<Observables: procedures>>=
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.
<<Observables: public>>=
public :: var_list_check_result_var
<<Observables: sub interfaces>>=
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
<<Observables: procedures>>=
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:
<<Observables: procedures>>=
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:
<<Observables: procedures>>=
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:
<<Observables: procedures>>=
function string_is_num_id (string) result (flag)
logical :: flag
type(string_t), intent(in) :: string
type(string_t) :: buffer, name, separator
buffer = string
call split (buffer, name, "(", separator=separator) ! ")"
if (separator == "(") then
select case (char (name))
case ("num_id")
flag = .true.
case default
flag = .false.
end select
else
flag = .false.
end if
end function string_is_num_id
@ %def string_is_num_id
@
Index: trunk/src/process_integration/process_integration.nw
===================================================================
--- trunk/src/process_integration/process_integration.nw (revision 8842)
+++ trunk/src/process_integration/process_integration.nw (revision 8843)
@@ -1,23945 +1,23946 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: integration and process objects and such
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Integration and Process Objects}
\includemodulegraph{process_integration}
This is the central part of the \whizard\ package. It provides the
functionality for evaluating structure functions, kinematics and matrix
elements, integration and event generation. It combines the various
parts that deal with those tasks individually and organizes the data
transfer between them.
\begin{description}
\item[subevt\_expr]
This enables process observables as (abstract) expressions, to be
evaluated for each process call.
\item[parton\_states]
A [[parton_state_t]] object represents an elementary partonic
interaction. There are two versions: one for the isolated
elementary process, one for the elementary process convoluted with
the structure-function chain. The parton state is an effective
state. It needs not coincide with the seed-kinematics state which is
used in evaluating phase space.
\item[process]
Here, all pieces are combined for the purpose of evaluating the
elementary processes. The whole algorithm is coded in terms of
abstract data types as defined in the appropriate modules: [[prc_core]]
for matrix-element evaluation, [[prc_core_def]] for the associated
configuration and driver, [[sf_base]] for beams and structure-functions,
[[phs_base]] for phase space, and [[mci_base]] for integration and event
generation.
\item[process\_config]
\item[process\_counter]
Very simple object for statistics
\item[process\_mci]
\item[pcm]
\item[kinematics]
\item[instances]
While the above modules set up all static information, the instances
have the changing event data. There are term and process instances but
no component instances.
\item[process\_stacks]
Process stacks collect process objects.
\end{description}
We combine here hard interactions, phase space, and (for scatterings)
structure functions and interfaces them to the integration module.
The process object implements the combination of a fixed beam and
structure-function setup with a number of elementary processes. The
latter are called process components. The process object
represents an entity which is supposedly observable. It should
be meaningful to talk about the cross section of a process.
The individual components of a process are, technically, processes
themselves, but they may have unphysical cross sections which have to
be added for a physical result. Process components may be exclusive
tree-level elementary processes, dipole subtraction term, loop
corrections, etc.
The beam and structure function setup is common to all process
components. Thus, there is only one instance of this part.
The process may be a scattering process or a decay process. In the
latter case, there are no structure functions, and the beam setup
consists of a single particle. Otherwise, the two classes are treated
on the same footing.
Once a sampling point has been chosen, a process determines a set of
partons with a correlated density matrix of quantum numbers. In
general, each sampling point will generate, for each process component,
one or more distinct parton configurations. This is the [[computed]]
state. The computed state is the subject of the multi-channel
integration algorithm.
For NLO computations, it is necessary to project the computed states
onto another set of parton configurations (e.g., by recombining
certain pairs). This is the [[observed]] state. When computing
partonic observables, the information is taken from the observed
state.
For the purpose of event generation, we will later select one parton
configuration from the observed state and collapse the correlated
quantum state. This configuration is then dressed by applying parton
shower, decays and hadronization. The decay chain, in particular,
combines a scattering process with possible subsequent decay processes
on the parton level, which are full-fledged process objects themselves.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Process observables}
We define an abstract [[subevt_expr_t]] object as an extension of the
[[subevt_t]] type. The object contains a local variable list, variable
instances (as targets for pointers in the variable list), and evaluation
trees. The evaluation trees reference both the variables and the [[subevt]].
There are two instances of the abstract type: one for process instances, one
for physical events. Both have a common logical expression [[selection]]
which determines whether the object passes user-defined cuts.
The intention is that we fill the [[subevt_t]] base object and compute the
variables once we have evaluated a kinematical phase space point (or a
complete event). We then evaluate the expressions and can use the results in
further calculations.
The [[process_expr_t]] extension contains furthermore scale and weight
expressions. The [[event_expr_t]] extension contains a reweighting-factor
expression and a logical expression for event analysis. In practice, we will
link the variable list of the [[event_obs]] object to the variable list of the
currently active [[process_obs]] object, such that the process variables are
available to both objects. Event variables are meaningful only for physical
events.
Note that there are unit tests, but they are deferred to the
[[expr_tests]] module.
<<[[subevt_expr.f90]]>>=
<<File header>>
module subevt_expr
<<Use kinds>>
<<Use strings>>
use lorentz
use subevents
use variables
use flavors
use quantum_numbers
use interactions
use particles
use expr_base
<<Standard module head>>
<<Subevt expr: public>>
<<Subevt expr: types>>
<<Subevt expr: interfaces>>
interface
<<Subevt expr: sub interfaces>>
end interface
end module subevt_expr
@ %def subevt_expr
@
<<[[subevt_expr_sub.f90]]>>=
<<File header>>
submodule (subevt_expr) subevt_expr_s
use constants, only: zero, one
use io_units
use format_utils, only: write_separator
use diagnostics
implicit none
contains
<<Subevt expr: procedures>>
end submodule subevt_expr_s
@ %def subevt_expr_s
@
\subsection{Abstract base type}
<<Subevt expr: types>>=
type, extends (subevt_t), abstract :: subevt_expr_t
logical :: subevt_filled = .false.
type(var_list_t) :: var_list
real(default) :: sqrts_hat = 0
integer :: n_in = 0
integer :: n_out = 0
integer :: n_tot = 0
logical :: has_selection = .false.
class(expr_t), allocatable :: selection
logical :: colorize_subevt = .false.
contains
<<Subevt expr: subevt expr: TBP>>
end type subevt_expr_t
@ %def subevt_expr_t
@ Output: Base and extended version. We already have a [[write]] routine for
the [[subevt_t]] parent type.
<<Subevt expr: subevt expr: TBP>>=
procedure :: base_write => subevt_expr_write
<<Subevt expr: sub interfaces>>=
module subroutine subevt_expr_write (object, unit, pacified)
class(subevt_expr_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacified
end subroutine subevt_expr_write
<<Subevt expr: procedures>>=
module subroutine subevt_expr_write (object, unit, pacified)
class(subevt_expr_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacified
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Local variables:"
call write_separator (u)
call object%var_list%write (u, follow_link=.false., &
pacified = pacified)
call write_separator (u)
if (object%subevt_filled) then
call object%subevt_t%write (u, pacified = pacified)
if (object%has_selection) then
call write_separator (u)
write (u, "(1x,A)") "Selection expression:"
call write_separator (u)
call object%selection%write (u)
end if
else
write (u, "(1x,A)") "subevt: [undefined]"
end if
end subroutine subevt_expr_write
@ %def subevt_expr_write
@ Finalizer.
<<Subevt expr: subevt expr: TBP>>=
procedure (subevt_expr_final), deferred :: final
procedure :: base_final => subevt_expr_final
<<Subevt expr: sub interfaces>>=
module subroutine subevt_expr_final (object)
class(subevt_expr_t), intent(inout) :: object
end subroutine subevt_expr_final
<<Subevt expr: procedures>>=
module subroutine subevt_expr_final (object)
class(subevt_expr_t), intent(inout) :: object
call object%var_list%final ()
if (object%has_selection) then
call object%selection%final ()
end if
end subroutine subevt_expr_final
@ %def subevt_expr_final
@
\subsection{Initialization}
Initialization: define local variables and establish pointers.
The common variables are [[sqrts]] (the nominal beam energy, fixed),
[[sqrts_hat]] (the actual energy), [[n_in]], [[n_out]], and [[n_tot]] for
the [[subevt]]. With the exception of [[sqrts]], all are implemented as
pointers to subobjects.
<<Subevt expr: subevt expr: TBP>>=
procedure (subevt_expr_setup_vars), deferred :: setup_vars
procedure :: base_setup_vars => subevt_expr_setup_vars
<<Subevt expr: sub interfaces>>=
module subroutine subevt_expr_setup_vars (expr, sqrts)
class(subevt_expr_t), intent(inout), target :: expr
real(default), intent(in) :: sqrts
end subroutine subevt_expr_setup_vars
<<Subevt expr: procedures>>=
module subroutine subevt_expr_setup_vars (expr, sqrts)
class(subevt_expr_t), intent(inout), target :: expr
real(default), intent(in) :: sqrts
call expr%var_list%final ()
call expr%var_list%append_real (var_str ("sqrts"), sqrts, &
locked = .true., verbose = .false., intrinsic = .true.)
call expr%var_list%append_real_ptr (var_str ("sqrts_hat"), &
expr%sqrts_hat, is_known = expr%subevt_filled, &
locked = .true., verbose = .false., intrinsic = .true.)
call expr%var_list%append_int_ptr (var_str ("n_in"), expr%n_in, &
is_known = expr%subevt_filled, &
locked = .true., verbose = .false., intrinsic = .true.)
call expr%var_list%append_int_ptr (var_str ("n_out"), expr%n_out, &
is_known = expr%subevt_filled, &
locked = .true., verbose = .false., intrinsic = .true.)
call expr%var_list%append_int_ptr (var_str ("n_tot"), expr%n_tot, &
is_known = expr%subevt_filled, &
locked = .true., verbose = .false., intrinsic = .true.)
end subroutine subevt_expr_setup_vars
@ %def subevt_expr_setup_vars
@ Append the subevent expr (its base-type core) itself to the variable
list, if it is not yet present.
<<Subevt expr: subevt expr: TBP>>=
procedure :: setup_var_self => subevt_expr_setup_var_self
<<Subevt expr: sub interfaces>>=
module subroutine subevt_expr_setup_var_self (expr)
class(subevt_expr_t), intent(inout), target :: expr
end subroutine subevt_expr_setup_var_self
<<Subevt expr: procedures>>=
module subroutine subevt_expr_setup_var_self (expr)
class(subevt_expr_t), intent(inout), target :: expr
if (.not. expr%var_list%contains (var_str ("@evt"))) then
call expr%var_list%append_subevt_ptr &
(var_str ("@evt"), expr%subevt_t, &
is_known = expr%subevt_filled, &
locked = .true., verbose = .false., intrinsic=.true.)
end if
end subroutine subevt_expr_setup_var_self
@ %def subevt_expr_setup_var_self
@ Link a variable list to the local one. This could be done event by event,
but before evaluating expressions.
<<Subevt expr: subevt expr: TBP>>=
procedure :: link_var_list => subevt_expr_link_var_list
<<Subevt expr: sub interfaces>>=
module subroutine subevt_expr_link_var_list (expr, var_list)
class(subevt_expr_t), intent(inout) :: expr
type(var_list_t), intent(in), target :: var_list
end subroutine subevt_expr_link_var_list
<<Subevt expr: procedures>>=
module subroutine subevt_expr_link_var_list (expr, var_list)
class(subevt_expr_t), intent(inout) :: expr
type(var_list_t), intent(in), target :: var_list
call expr%var_list%link (var_list)
end subroutine subevt_expr_link_var_list
@ %def subevt_expr_link_var_list
@ Compile the selection expression. If there is no expression, the build
method will not allocate the expression object.
<<Subevt expr: subevt expr: TBP>>=
procedure :: setup_selection => subevt_expr_setup_selection
<<Subevt expr: sub interfaces>>=
module subroutine subevt_expr_setup_selection (expr, ef_cuts)
class(subevt_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_cuts
end subroutine subevt_expr_setup_selection
<<Subevt expr: procedures>>=
module subroutine subevt_expr_setup_selection (expr, ef_cuts)
class(subevt_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_cuts
call ef_cuts%build (expr%selection)
if (allocated (expr%selection)) then
call expr%setup_var_self ()
call expr%selection%setup_lexpr (expr%var_list)
expr%has_selection = .true.
end if
end subroutine subevt_expr_setup_selection
@ %def subevt_expr_setup_selection
@ (De)activate color storage and evaluation for the expression. The subevent
particles will have color information.
<<Subevt expr: subevt expr: TBP>>=
procedure :: colorize => subevt_expr_colorize
<<Subevt expr: sub interfaces>>=
module subroutine subevt_expr_colorize (expr, colorize_subevt)
class(subevt_expr_t), intent(inout), target :: expr
logical, intent(in) :: colorize_subevt
end subroutine subevt_expr_colorize
<<Subevt expr: procedures>>=
module subroutine subevt_expr_colorize (expr, colorize_subevt)
class(subevt_expr_t), intent(inout), target :: expr
logical, intent(in) :: colorize_subevt
expr%colorize_subevt = colorize_subevt
end subroutine subevt_expr_colorize
@ %def subevt_expr_colorize
@
\subsection{Evaluation}
Reset to initial state, i.e., mark the [[subevt]] as invalid.
<<Subevt expr: subevt expr: TBP>>=
procedure :: reset_contents => subevt_expr_reset_contents
procedure :: base_reset_contents => subevt_expr_reset_contents
<<Subevt expr: sub interfaces>>=
module subroutine subevt_expr_reset_contents (expr)
class(subevt_expr_t), intent(inout) :: expr
end subroutine subevt_expr_reset_contents
<<Subevt expr: procedures>>=
module subroutine subevt_expr_reset_contents (expr)
class(subevt_expr_t), intent(inout) :: expr
expr%subevt_filled = .false.
end subroutine subevt_expr_reset_contents
@ %def subevt_expr_reset_contents
@ Evaluate the selection expression and return the result. There is also a
deferred version: this should evaluate the remaining expressions if the event
has passed.
<<Subevt expr: subevt expr: TBP>>=
procedure :: base_evaluate => subevt_expr_evaluate
<<Subevt expr: sub interfaces>>=
module subroutine subevt_expr_evaluate (expr, passed)
class(subevt_expr_t), intent(inout) :: expr
logical, intent(out) :: passed
end subroutine subevt_expr_evaluate
<<Subevt expr: procedures>>=
module subroutine subevt_expr_evaluate (expr, passed)
class(subevt_expr_t), intent(inout) :: expr
logical, intent(out) :: passed
if (expr%has_selection) then
call expr%selection%evaluate ()
if (expr%selection%is_known ()) then
passed = expr%selection%get_log ()
else
call msg_error ("Evaluate selection expression: result undefined")
passed = .false.
end if
else
passed = .true.
end if
end subroutine subevt_expr_evaluate
@ %def subevt_expr_evaluate
@
\subsection{Implementation for partonic events}
This implementation contains the expressions that we can evaluate for the
partonic process during integration.
<<Subevt expr: public>>=
public :: parton_expr_t
<<Subevt expr: types>>=
type, extends (subevt_expr_t) :: parton_expr_t
integer, dimension(:), allocatable :: i_beam
integer, dimension(:), allocatable :: i_in
integer, dimension(:), allocatable :: i_out
logical :: has_scale = .false.
logical :: has_fac_scale = .false.
logical :: has_ren_scale = .false.
logical :: has_weight = .false.
class(expr_t), allocatable :: scale
class(expr_t), allocatable :: fac_scale
class(expr_t), allocatable :: ren_scale
class(expr_t), allocatable :: weight
contains
<<Subevt expr: parton expr: TBP>>
end type parton_expr_t
@ %def parton_expr_t
@ Finalizer.
<<Subevt expr: parton expr: TBP>>=
procedure :: final => parton_expr_final
<<Subevt expr: sub interfaces>>=
module subroutine parton_expr_final (object)
class(parton_expr_t), intent(inout) :: object
end subroutine parton_expr_final
<<Subevt expr: procedures>>=
module subroutine parton_expr_final (object)
class(parton_expr_t), intent(inout) :: object
call object%base_final ()
if (object%has_scale) then
call object%scale%final ()
end if
if (object%has_fac_scale) then
call object%fac_scale%final ()
end if
if (object%has_ren_scale) then
call object%ren_scale%final ()
end if
if (object%has_weight) then
call object%weight%final ()
end if
end subroutine parton_expr_final
@ %def parton_expr_final
@ Output: continue writing the active expressions, after the common selection
expression.
Note: the [[prefix]] argument is declared in the [[write]] method of the
[[subevt_t]] base type. Here, it is unused.
<<Subevt expr: parton expr: TBP>>=
procedure :: write => parton_expr_write
<<Subevt expr: sub interfaces>>=
module subroutine parton_expr_write (object, unit, prefix, pacified)
class(parton_expr_t), intent(in) :: object
integer, intent(in), optional :: unit
character(*), intent(in), optional :: prefix
logical, intent(in), optional :: pacified
end subroutine parton_expr_write
<<Subevt expr: procedures>>=
module subroutine parton_expr_write (object, unit, prefix, pacified)
class(parton_expr_t), intent(in) :: object
integer, intent(in), optional :: unit
character(*), intent(in), optional :: prefix
logical, intent(in), optional :: pacified
integer :: u
u = given_output_unit (unit)
call object%base_write (u, pacified = pacified)
if (object%subevt_filled) then
if (object%has_scale) then
call write_separator (u)
write (u, "(1x,A)") "Scale expression:"
call write_separator (u)
call object%scale%write (u)
end if
if (object%has_fac_scale) then
call write_separator (u)
write (u, "(1x,A)") "Factorization scale expression:"
call write_separator (u)
call object%fac_scale%write (u)
end if
if (object%has_ren_scale) then
call write_separator (u)
write (u, "(1x,A)") "Renormalization scale expression:"
call write_separator (u)
call object%ren_scale%write (u)
end if
if (object%has_weight) then
call write_separator (u)
write (u, "(1x,A)") "Weight expression:"
call write_separator (u)
call object%weight%write (u)
end if
end if
end subroutine parton_expr_write
@ %def parton_expr_write
@ Define variables.
<<Subevt expr: parton expr: TBP>>=
procedure :: setup_vars => parton_expr_setup_vars
<<Subevt expr: sub interfaces>>=
module subroutine parton_expr_setup_vars (expr, sqrts)
class(parton_expr_t), intent(inout), target :: expr
real(default), intent(in) :: sqrts
end subroutine parton_expr_setup_vars
<<Subevt expr: procedures>>=
module subroutine parton_expr_setup_vars (expr, sqrts)
class(parton_expr_t), intent(inout), target :: expr
real(default), intent(in) :: sqrts
call expr%base_setup_vars (sqrts)
end subroutine parton_expr_setup_vars
@ %def parton_expr_setup_vars
@ Compile the scale expressions. If a pointer is disassociated, there is
no expression.
<<Subevt expr: parton expr: TBP>>=
procedure :: setup_scale => parton_expr_setup_scale
procedure :: setup_fac_scale => parton_expr_setup_fac_scale
procedure :: setup_ren_scale => parton_expr_setup_ren_scale
<<Subevt expr: sub interfaces>>=
module subroutine parton_expr_setup_scale (expr, ef_scale)
class(parton_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_scale
end subroutine parton_expr_setup_scale
module subroutine parton_expr_setup_fac_scale (expr, ef_fac_scale)
class(parton_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_fac_scale
end subroutine parton_expr_setup_fac_scale
module subroutine parton_expr_setup_ren_scale (expr, ef_ren_scale)
class(parton_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_ren_scale
end subroutine parton_expr_setup_ren_scale
<<Subevt expr: procedures>>=
module subroutine parton_expr_setup_scale (expr, ef_scale)
class(parton_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_scale
call ef_scale%build (expr%scale)
if (allocated (expr%scale)) then
call expr%setup_var_self ()
call expr%scale%setup_expr (expr%var_list)
expr%has_scale = .true.
end if
end subroutine parton_expr_setup_scale
module subroutine parton_expr_setup_fac_scale (expr, ef_fac_scale)
class(parton_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_fac_scale
call ef_fac_scale%build (expr%fac_scale)
if (allocated (expr%fac_scale)) then
call expr%setup_var_self ()
call expr%fac_scale%setup_expr (expr%var_list)
expr%has_fac_scale = .true.
end if
end subroutine parton_expr_setup_fac_scale
module subroutine parton_expr_setup_ren_scale (expr, ef_ren_scale)
class(parton_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_ren_scale
call ef_ren_scale%build (expr%ren_scale)
if (allocated (expr%ren_scale)) then
call expr%setup_var_self ()
call expr%ren_scale%setup_expr (expr%var_list)
expr%has_ren_scale = .true.
end if
end subroutine parton_expr_setup_ren_scale
@ %def parton_expr_setup_scale
@ %def parton_expr_setup_fac_scale
@ %def parton_expr_setup_ren_scale
@ Compile the weight expression.
<<Subevt expr: parton expr: TBP>>=
procedure :: setup_weight => parton_expr_setup_weight
<<Subevt expr: sub interfaces>>=
module subroutine parton_expr_setup_weight (expr, ef_weight)
class(parton_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_weight
end subroutine parton_expr_setup_weight
<<Subevt expr: procedures>>=
module subroutine parton_expr_setup_weight (expr, ef_weight)
class(parton_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_weight
call ef_weight%build (expr%weight)
if (allocated (expr%weight)) then
call expr%setup_var_self ()
call expr%weight%setup_expr (expr%var_list)
expr%has_weight = .true.
end if
end subroutine parton_expr_setup_weight
@ %def parton_expr_setup_weight
@ Filling the partonic state consists of two parts. The first routine
prepares the subevt without assigning momenta. It takes the particles from an
[[interaction_t]]. It needs the indices and flavors for the beam,
incoming, and outgoing particles.
We can assume that the particle content of the subevt does not change.
Therefore, we set the event variables [[n_in]], [[n_out]], [[n_tot]] already
in this initialization step.
<<Subevt expr: parton expr: TBP>>=
procedure :: setup_subevt => parton_expr_setup_subevt
<<Subevt expr: sub interfaces>>=
module subroutine parton_expr_setup_subevt (expr, int, &
i_beam, i_in, i_out, f_beam, f_in, f_out)
class(parton_expr_t), intent(inout) :: expr
type(interaction_t), intent(in), target :: int
integer, dimension(:), intent(in) :: i_beam, i_in, i_out
type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
end subroutine parton_expr_setup_subevt
<<Subevt expr: procedures>>=
module subroutine parton_expr_setup_subevt (expr, int, &
i_beam, i_in, i_out, f_beam, f_in, f_out)
class(parton_expr_t), intent(inout) :: expr
type(interaction_t), intent(in), target :: int
integer, dimension(:), intent(in) :: i_beam, i_in, i_out
type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
allocate (expr%i_beam (size (i_beam)))
allocate (expr%i_in (size (i_in)))
allocate (expr%i_out (size (i_out)))
expr%i_beam = i_beam
expr%i_in = i_in
expr%i_out = i_out
call interaction_to_subevt (int, &
expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t)
call expr%set_pdg_beam (f_beam%get_pdg ())
call expr%set_pdg_incoming (f_in%get_pdg ())
call expr%set_pdg_outgoing (f_out%get_pdg ())
call expr%set_p2_beam (f_beam%get_mass () ** 2)
call expr%set_p2_incoming (f_in%get_mass () ** 2)
call expr%set_p2_outgoing (f_out%get_mass () ** 2)
expr%n_in = size (i_in)
expr%n_out = size (i_out)
expr%n_tot = expr%n_in + expr%n_out
end subroutine parton_expr_setup_subevt
@ %def parton_expr_setup_subevt
<<Subevt expr: parton expr: TBP>>=
procedure :: renew_flv_content_subevt => parton_expr_renew_flv_content_subevt
<<Subevt expr: sub interfaces>>=
module subroutine parton_expr_renew_flv_content_subevt (expr, int, &
i_beam, i_in, i_out, f_beam, f_in, f_out)
class(parton_expr_t), intent(inout) :: expr
type(interaction_t), intent(in), target :: int
integer, dimension(:), intent(in) :: i_beam, i_in, i_out
type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
end subroutine parton_expr_renew_flv_content_subevt
<<Subevt expr: procedures>>=
module subroutine parton_expr_renew_flv_content_subevt (expr, int, &
i_beam, i_in, i_out, f_beam, f_in, f_out)
class(parton_expr_t), intent(inout) :: expr
type(interaction_t), intent(in), target :: int
integer, dimension(:), intent(in) :: i_beam, i_in, i_out
type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
expr%i_beam = i_beam
expr%i_in = i_in
expr%i_out = i_out
call expr%set_pdg_beam (f_beam%get_pdg ())
call expr%set_pdg_incoming (f_in%get_pdg ())
call expr%set_pdg_outgoing (f_out%get_pdg ())
expr%n_in = size (i_in)
expr%n_out = size (i_out)
expr%n_tot = expr%n_in + expr%n_out
end subroutine parton_expr_renew_flv_content_subevt
@ %def parton_expr_renew_flv_content_subevt
@ Transfer PDG codes, masses (initalization) and momenta to a
predefined subevent. We use the flavor assignment of the first
branch in the interaction state matrix. Only incoming and outgoing
particles are transferred. Switch momentum sign for incoming
particles.
<<Subevt expr: interfaces>>=
interface interaction_momenta_to_subevt
module procedure interaction_momenta_to_subevt_id
module procedure interaction_momenta_to_subevt_tr
end interface
<<Subevt expr: sub interfaces>>=
module subroutine interaction_momenta_to_subevt_id &
(int, j_beam, j_in, j_out, subevt)
type(interaction_t), intent(in) :: int
integer, dimension(:), intent(in) :: j_beam, j_in, j_out
type(subevt_t), intent(inout) :: subevt
end subroutine interaction_momenta_to_subevt_id
module subroutine interaction_momenta_to_subevt_tr &
(int, j_beam, j_in, j_out, lt, subevt)
type(interaction_t), intent(in) :: int
integer, dimension(:), intent(in) :: j_beam, j_in, j_out
type(subevt_t), intent(inout) :: subevt
type(lorentz_transformation_t), intent(in) :: lt
end subroutine interaction_momenta_to_subevt_tr
<<Subevt expr: procedures>>=
subroutine interaction_to_subevt (int, j_beam, j_in, j_out, subevt)
type(interaction_t), intent(in), target :: int
integer, dimension(:), intent(in) :: j_beam, j_in, j_out
type(subevt_t), intent(out) :: subevt
type(flavor_t), dimension(:), allocatable :: flv
integer :: n_beam, n_in, n_out, i, j
allocate (flv (int%get_n_tot ()))
flv = quantum_numbers_get_flavor (int%get_quantum_numbers (1))
n_beam = size (j_beam)
n_in = size (j_in)
n_out = size (j_out)
call subevt_init (subevt, n_beam + n_in + n_out)
do i = 1, n_beam
j = j_beam(i)
call subevt%set_beam (i, flv(j)%get_pdg (), &
vector4_null, flv(j)%get_mass () ** 2)
end do
do i = 1, n_in
j = j_in(i)
call subevt%set_incoming (n_beam + i, flv(j)%get_pdg (), &
vector4_null, flv(j)%get_mass () ** 2)
end do
do i = 1, n_out
j = j_out(i)
call subevt%set_outgoing (n_beam + n_in + i, &
flv(j)%get_pdg (), vector4_null, &
flv(j)%get_mass () ** 2)
end do
end subroutine interaction_to_subevt
module subroutine interaction_momenta_to_subevt_id &
(int, j_beam, j_in, j_out, subevt)
type(interaction_t), intent(in) :: int
integer, dimension(:), intent(in) :: j_beam, j_in, j_out
type(subevt_t), intent(inout) :: subevt
call subevt%set_p_beam (- int%get_momenta (j_beam))
call subevt%set_p_incoming (- int%get_momenta (j_in))
call subevt%set_p_outgoing (int%get_momenta (j_out))
end subroutine interaction_momenta_to_subevt_id
module subroutine interaction_momenta_to_subevt_tr &
(int, j_beam, j_in, j_out, lt, subevt)
type(interaction_t), intent(in) :: int
integer, dimension(:), intent(in) :: j_beam, j_in, j_out
type(subevt_t), intent(inout) :: subevt
type(lorentz_transformation_t), intent(in) :: lt
call subevt%set_p_beam (- lt * int%get_momenta (j_beam))
call subevt%set_p_incoming (- lt * int%get_momenta (j_in))
call subevt%set_p_outgoing (lt * int%get_momenta (j_out))
end subroutine interaction_momenta_to_subevt_tr
@ %def interaction_momenta_to_subevt
@ The second part takes the momenta from the interaction object and thus
completes the subevt. The partonic energy can then be computed.
<<Subevt expr: parton expr: TBP>>=
procedure :: fill_subevt => parton_expr_fill_subevt
<<Subevt expr: sub interfaces>>=
module subroutine parton_expr_fill_subevt (expr, int)
class(parton_expr_t), intent(inout) :: expr
type(interaction_t), intent(in), target :: int
end subroutine parton_expr_fill_subevt
<<Subevt expr: procedures>>=
module subroutine parton_expr_fill_subevt (expr, int)
class(parton_expr_t), intent(inout) :: expr
type(interaction_t), intent(in), target :: int
call interaction_momenta_to_subevt (int, &
expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t)
expr%sqrts_hat = expr%get_sqrts_hat ()
expr%subevt_filled = .true.
end subroutine parton_expr_fill_subevt
@ %def parton_expr_fill_subevt
@ Evaluate, if the event passes the selection. For absent expressions we take
default values.
<<Subevt expr: parton expr: TBP>>=
procedure :: evaluate => parton_expr_evaluate
<<Subevt expr: sub interfaces>>=
module subroutine parton_expr_evaluate (expr, passed, scale, fac_scale, &
ren_scale, weight, scale_forced, force_evaluation)
class(parton_expr_t), intent(inout) :: expr
logical, intent(out) :: passed
real(default), intent(out) :: scale
real(default), allocatable, intent(out) :: fac_scale
real(default), allocatable, intent(out) :: ren_scale
real(default), intent(out) :: weight
real(default), intent(in), allocatable, optional :: scale_forced
logical, intent(in), optional :: force_evaluation
end subroutine parton_expr_evaluate
<<Subevt expr: procedures>>=
module subroutine parton_expr_evaluate (expr, passed, scale, fac_scale, &
ren_scale, weight, scale_forced, force_evaluation)
class(parton_expr_t), intent(inout) :: expr
logical, intent(out) :: passed
real(default), intent(out) :: scale
real(default), allocatable, intent(out) :: fac_scale
real(default), allocatable, intent(out) :: ren_scale
real(default), intent(out) :: weight
real(default), intent(in), allocatable, optional :: scale_forced
logical, intent(in), optional :: force_evaluation
logical :: force_scale, force_eval
force_scale = .false.; force_eval = .false.
if (present (scale_forced)) force_scale = allocated (scale_forced)
if (present (force_evaluation)) force_eval = force_evaluation
call expr%base_evaluate (passed)
if (passed .or. force_eval) then
if (force_scale) then
scale = scale_forced
else if (expr%has_scale) then
call expr%scale%evaluate ()
if (expr%scale%is_known ()) then
scale = expr%scale%get_real ()
else
call msg_error ("Evaluate scale expression: result undefined")
scale = zero
end if
else
scale = expr%sqrts_hat
end if
if (expr%has_fac_scale) then
call expr%fac_scale%evaluate ()
if (expr%fac_scale%is_known ()) then
if (.not. allocated (fac_scale)) then
allocate (fac_scale, source = expr%fac_scale%get_real ())
else
fac_scale = expr%fac_scale%get_real ()
end if
else
call msg_error ("Evaluate factorization scale expression: &
&result undefined")
end if
end if
if (expr%has_ren_scale) then
call expr%ren_scale%evaluate ()
if (expr%ren_scale%is_known ()) then
if (.not. allocated (ren_scale)) then
allocate (ren_scale, source = expr%ren_scale%get_real ())
else
ren_scale = expr%ren_scale%get_real ()
end if
else
call msg_error ("Evaluate renormalization scale expression: &
&result undefined")
end if
end if
if (expr%has_weight) then
call expr%weight%evaluate ()
if (expr%weight%is_known ()) then
weight = expr%weight%get_real ()
else
call msg_error ("Evaluate weight expression: result undefined")
weight = zero
end if
else
weight = one
end if
else
weight = zero
end if
end subroutine parton_expr_evaluate
@ %def parton_expr_evaluate
@ Return the beam/incoming parton indices.
<<Subevt expr: parton expr: TBP>>=
procedure :: get_beam_index => parton_expr_get_beam_index
procedure :: get_in_index => parton_expr_get_in_index
<<Subevt expr: sub interfaces>>=
module subroutine parton_expr_get_beam_index (expr, i_beam)
class(parton_expr_t), intent(in) :: expr
integer, dimension(:), intent(out) :: i_beam
end subroutine parton_expr_get_beam_index
module subroutine parton_expr_get_in_index (expr, i_in)
class(parton_expr_t), intent(in) :: expr
integer, dimension(:), intent(out) :: i_in
end subroutine parton_expr_get_in_index
<<Subevt expr: procedures>>=
module subroutine parton_expr_get_beam_index (expr, i_beam)
class(parton_expr_t), intent(in) :: expr
integer, dimension(:), intent(out) :: i_beam
i_beam = expr%i_beam
end subroutine parton_expr_get_beam_index
module subroutine parton_expr_get_in_index (expr, i_in)
class(parton_expr_t), intent(in) :: expr
integer, dimension(:), intent(out) :: i_in
i_in = expr%i_in
end subroutine parton_expr_get_in_index
@ %def parton_expr_get_beam_index
@ %def parton_expr_get_in_index
@
\subsection{Implementation for full events}
This implementation contains the expressions that we can evaluate for the
full event. It also contains data that pertain to the event, suitable
for communication with external event formats. These data
simultaneously serve as pointer targets for the variable lists hidden
in the expressions (eval trees).
Squared matrix element and weight values: when reading events from
file, the [[ref]] value is the number in the file, while the [[prc]]
value is the number that we calculate from the momenta in the file,
possibly with different parameters. When generating events the first
time, or if we do not recalculate, the numbers should coincide.
Furthermore, the array of [[alt]] values is copied from an array of
alternative event records. These values should represent calculated
values.
<<Subevt expr: public>>=
public :: event_expr_t
<<Subevt expr: types>>=
type, extends (subevt_expr_t) :: event_expr_t
logical :: has_reweight = .false.
logical :: has_analysis = .false.
class(expr_t), allocatable :: reweight
class(expr_t), allocatable :: analysis
logical :: has_id = .false.
type(string_t) :: id
logical :: has_num_id = .false.
integer :: num_id = 0
logical :: has_index = .false.
integer :: index = 0
logical :: has_sqme_ref = .false.
real(default) :: sqme_ref = 0
logical :: has_sqme_prc = .false.
real(default) :: sqme_prc = 0
logical :: has_weight_ref = .false.
real(default) :: weight_ref = 0
logical :: has_weight_prc = .false.
real(default) :: weight_prc = 0
logical :: has_excess_prc = .false.
real(default) :: excess_prc = 0
integer :: n_alt = 0
logical :: has_sqme_alt = .false.
real(default), dimension(:), allocatable :: sqme_alt
logical :: has_weight_alt = .false.
real(default), dimension(:), allocatable :: weight_alt
contains
<<Subevt expr: event expr: TBP>>
end type event_expr_t
@ %def event_expr_t
@ Finalizer for the expressions.
<<Subevt expr: event expr: TBP>>=
procedure :: final => event_expr_final
<<Subevt expr: sub interfaces>>=
module subroutine event_expr_final (object)
class(event_expr_t), intent(inout) :: object
end subroutine event_expr_final
<<Subevt expr: procedures>>=
module subroutine event_expr_final (object)
class(event_expr_t), intent(inout) :: object
call object%base_final ()
if (object%has_reweight) then
call object%reweight%final ()
end if
if (object%has_analysis) then
call object%analysis%final ()
end if
end subroutine event_expr_final
@ %def event_expr_final
@ Output: continue writing the active expressions, after the common selection
expression.
Note: the [[prefix]] argument is declared in the [[write]] method of the
[[subevt_t]] base type. Here, it is unused.
<<Subevt expr: event expr: TBP>>=
procedure :: write => event_expr_write
<<Subevt expr: sub interfaces>>=
module subroutine event_expr_write (object, unit, prefix, pacified)
class(event_expr_t), intent(in) :: object
integer, intent(in), optional :: unit
character(*), intent(in), optional :: prefix
logical, intent(in), optional :: pacified
end subroutine event_expr_write
<<Subevt expr: procedures>>=
module subroutine event_expr_write (object, unit, prefix, pacified)
class(event_expr_t), intent(in) :: object
integer, intent(in), optional :: unit
character(*), intent(in), optional :: prefix
logical, intent(in), optional :: pacified
integer :: u
u = given_output_unit (unit)
call object%base_write (u, pacified = pacified)
if (object%subevt_filled) then
if (object%has_reweight) then
call write_separator (u)
write (u, "(1x,A)") "Reweighting expression:"
call write_separator (u)
call object%reweight%write (u)
end if
if (object%has_analysis) then
call write_separator (u)
write (u, "(1x,A)") "Analysis expression:"
call write_separator (u)
call object%analysis%write (u)
end if
end if
end subroutine event_expr_write
@ %def event_expr_write
@ Initializer. This is required only for the [[sqme_alt]] and
[[weight_alt]] arrays.
<<Subevt expr: event expr: TBP>>=
procedure :: init => event_expr_init
<<Subevt expr: sub interfaces>>=
module subroutine event_expr_init (expr, n_alt)
class(event_expr_t), intent(out) :: expr
integer, intent(in), optional :: n_alt
end subroutine event_expr_init
<<Subevt expr: procedures>>=
module subroutine event_expr_init (expr, n_alt)
class(event_expr_t), intent(out) :: expr
integer, intent(in), optional :: n_alt
if (present (n_alt)) then
expr%n_alt = n_alt
allocate (expr%sqme_alt (n_alt), source = 0._default)
allocate (expr%weight_alt (n_alt), source = 0._default)
end if
end subroutine event_expr_init
@ %def event_expr_init
@ Define variables. We have the variables of the base type plus
specific variables for full events. There is the event index.
<<Subevt expr: event expr: TBP>>=
procedure :: setup_vars => event_expr_setup_vars
<<Subevt expr: sub interfaces>>=
module subroutine event_expr_setup_vars (expr, sqrts)
class(event_expr_t), intent(inout), target :: expr
real(default), intent(in) :: sqrts
end subroutine event_expr_setup_vars
<<Subevt expr: procedures>>=
module subroutine event_expr_setup_vars (expr, sqrts)
class(event_expr_t), intent(inout), target :: expr
real(default), intent(in) :: sqrts
call expr%base_setup_vars (sqrts)
call expr%var_list%append_string_ptr (var_str ("$process_id"), &
expr%id, is_known = expr%has_id, &
locked = .true., verbose = .false., intrinsic = .true.)
call expr%var_list%append_int_ptr (var_str ("process_num_id"), &
expr%num_id, is_known = expr%has_num_id, &
locked = .true., verbose = .false., intrinsic = .true.)
call expr%var_list%append_real_ptr (var_str ("sqme"), &
expr%sqme_prc, is_known = expr%has_sqme_prc, &
locked = .true., verbose = .false., intrinsic = .true.)
call expr%var_list%append_real_ptr (var_str ("sqme_ref"), &
expr%sqme_ref, is_known = expr%has_sqme_ref, &
locked = .true., verbose = .false., intrinsic = .true.)
call expr%var_list%append_int_ptr (var_str ("event_index"), &
expr%index, is_known = expr%has_index, &
locked = .true., verbose = .false., intrinsic = .true.)
call expr%var_list%append_real_ptr (var_str ("event_weight"), &
expr%weight_prc, is_known = expr%has_weight_prc, &
locked = .true., verbose = .false., intrinsic = .true.)
call expr%var_list%append_real_ptr (var_str ("event_weight_ref"), &
expr%weight_ref, is_known = expr%has_weight_ref, &
locked = .true., verbose = .false., intrinsic = .true.)
call expr%var_list%append_real_ptr (var_str ("event_excess"), &
expr%excess_prc, is_known = expr%has_excess_prc, &
locked = .true., verbose = .false., intrinsic = .true.)
end subroutine event_expr_setup_vars
@ %def event_expr_setup_vars
@ Compile the analysis expression. If the pointer is disassociated, there is
no expression.
<<Subevt expr: event expr: TBP>>=
procedure :: setup_analysis => event_expr_setup_analysis
<<Subevt expr: sub interfaces>>=
module subroutine event_expr_setup_analysis (expr, ef_analysis)
class(event_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_analysis
end subroutine event_expr_setup_analysis
<<Subevt expr: procedures>>=
module subroutine event_expr_setup_analysis (expr, ef_analysis)
class(event_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_analysis
call ef_analysis%build (expr%analysis)
if (allocated (expr%analysis)) then
call expr%setup_var_self ()
call expr%analysis%setup_lexpr (expr%var_list)
expr%has_analysis = .true.
end if
end subroutine event_expr_setup_analysis
@ %def event_expr_setup_analysis
@ Compile the reweight expression.
<<Subevt expr: event expr: TBP>>=
procedure :: setup_reweight => event_expr_setup_reweight
<<Subevt expr: sub interfaces>>=
module subroutine event_expr_setup_reweight (expr, ef_reweight)
class(event_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_reweight
end subroutine event_expr_setup_reweight
<<Subevt expr: procedures>>=
module subroutine event_expr_setup_reweight (expr, ef_reweight)
class(event_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_reweight
call ef_reweight%build (expr%reweight)
if (allocated (expr%reweight)) then
call expr%setup_var_self ()
call expr%reweight%setup_expr (expr%var_list)
expr%has_reweight = .true.
end if
end subroutine event_expr_setup_reweight
@ %def event_expr_setup_reweight
@ Store the string or numeric process ID. This should be done during
initialization.
<<Subevt expr: event expr: TBP>>=
procedure :: set_process_id => event_expr_set_process_id
procedure :: set_process_num_id => event_expr_set_process_num_id
<<Subevt expr: sub interfaces>>=
module subroutine event_expr_set_process_id (expr, id)
class(event_expr_t), intent(inout) :: expr
type(string_t), intent(in) :: id
end subroutine event_expr_set_process_id
module subroutine event_expr_set_process_num_id (expr, num_id)
class(event_expr_t), intent(inout) :: expr
integer, intent(in) :: num_id
end subroutine event_expr_set_process_num_id
<<Subevt expr: procedures>>=
module subroutine event_expr_set_process_id (expr, id)
class(event_expr_t), intent(inout) :: expr
type(string_t), intent(in) :: id
expr%id = id
expr%has_id = .true.
end subroutine event_expr_set_process_id
module subroutine event_expr_set_process_num_id (expr, num_id)
class(event_expr_t), intent(inout) :: expr
integer, intent(in) :: num_id
expr%num_id = num_id
expr%has_num_id = .true.
end subroutine event_expr_set_process_num_id
@ %def event_expr_set_process_id
@ %def event_expr_set_process_num_id
@ Reset / set the data that pertain to a particular event. The event
index is reset unless explicitly told to keep it.
<<Subevt expr: event expr: TBP>>=
procedure :: reset_contents => event_expr_reset_contents
procedure :: set => event_expr_set
<<Subevt expr: sub interfaces>>=
module subroutine event_expr_reset_contents (expr)
class(event_expr_t), intent(inout) :: expr
end subroutine event_expr_reset_contents
module subroutine event_expr_set (expr, &
weight_ref, weight_prc, weight_alt, &
excess_prc, &
sqme_ref, sqme_prc, sqme_alt)
class(event_expr_t), intent(inout) :: expr
real(default), intent(in), optional :: weight_ref, weight_prc
real(default), intent(in), optional :: excess_prc
real(default), intent(in), optional :: sqme_ref, sqme_prc
real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt
end subroutine event_expr_set
<<Subevt expr: procedures>>=
module subroutine event_expr_reset_contents (expr)
class(event_expr_t), intent(inout) :: expr
call expr%base_reset_contents ()
expr%has_sqme_ref = .false.
expr%has_sqme_prc = .false.
expr%has_sqme_alt = .false.
expr%has_weight_ref = .false.
expr%has_weight_prc = .false.
expr%has_weight_alt = .false.
expr%has_excess_prc = .false.
end subroutine event_expr_reset_contents
module subroutine event_expr_set (expr, &
weight_ref, weight_prc, weight_alt, &
excess_prc, &
sqme_ref, sqme_prc, sqme_alt)
class(event_expr_t), intent(inout) :: expr
real(default), intent(in), optional :: weight_ref, weight_prc
real(default), intent(in), optional :: excess_prc
real(default), intent(in), optional :: sqme_ref, sqme_prc
real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt
if (present (sqme_ref)) then
expr%has_sqme_ref = .true.
expr%sqme_ref = sqme_ref
end if
if (present (sqme_prc)) then
expr%has_sqme_prc = .true.
expr%sqme_prc = sqme_prc
end if
if (present (sqme_alt)) then
expr%has_sqme_alt = .true.
expr%sqme_alt = sqme_alt
end if
if (present (weight_ref)) then
expr%has_weight_ref = .true.
expr%weight_ref = weight_ref
end if
if (present (weight_prc)) then
expr%has_weight_prc = .true.
expr%weight_prc = weight_prc
end if
if (present (weight_alt)) then
expr%has_weight_alt = .true.
expr%weight_alt = weight_alt
end if
if (present (excess_prc)) then
expr%has_excess_prc = .true.
expr%excess_prc = excess_prc
end if
end subroutine event_expr_set
@ %def event_expr_reset_contents event_expr_set
@ Access the subevent index.
<<Subevt expr: event expr: TBP>>=
procedure :: has_event_index => event_expr_has_event_index
procedure :: get_event_index => event_expr_get_event_index
<<Subevt expr: sub interfaces>>=
module function event_expr_has_event_index (expr) result (flag)
class(event_expr_t), intent(in) :: expr
logical :: flag
end function event_expr_has_event_index
module function event_expr_get_event_index (expr) result (index)
class(event_expr_t), intent(in) :: expr
integer :: index
end function event_expr_get_event_index
<<Subevt expr: procedures>>=
module function event_expr_has_event_index (expr) result (flag)
class(event_expr_t), intent(in) :: expr
logical :: flag
flag = expr%has_index
end function event_expr_has_event_index
module function event_expr_get_event_index (expr) result (index)
class(event_expr_t), intent(in) :: expr
integer :: index
if (expr%has_index) then
index = expr%index
else
index = 0
end if
end function event_expr_get_event_index
@ %def event_expr_has_event_index
@ %def event_expr_get_event_index
@ Set/increment the subevent index. Initialize it if necessary.
<<Subevt expr: event expr: TBP>>=
procedure :: set_event_index => event_expr_set_event_index
procedure :: reset_event_index => event_expr_reset_event_index
procedure :: increment_event_index => event_expr_increment_event_index
<<Subevt expr: sub interfaces>>=
module subroutine event_expr_set_event_index (expr, index)
class(event_expr_t), intent(inout) :: expr
integer, intent(in) :: index
end subroutine event_expr_set_event_index
module subroutine event_expr_reset_event_index (expr)
class(event_expr_t), intent(inout) :: expr
end subroutine event_expr_reset_event_index
module subroutine event_expr_increment_event_index (expr, offset)
class(event_expr_t), intent(inout) :: expr
integer, intent(in), optional :: offset
end subroutine event_expr_increment_event_index
<<Subevt expr: procedures>>=
module subroutine event_expr_set_event_index (expr, index)
class(event_expr_t), intent(inout) :: expr
integer, intent(in) :: index
expr%index = index
expr%has_index = .true.
end subroutine event_expr_set_event_index
module subroutine event_expr_reset_event_index (expr)
class(event_expr_t), intent(inout) :: expr
expr%has_index = .false.
end subroutine event_expr_reset_event_index
module subroutine event_expr_increment_event_index (expr, offset)
class(event_expr_t), intent(inout) :: expr
integer, intent(in), optional :: offset
if (expr%has_index) then
expr%index = expr%index + 1
else if (present (offset)) then
call expr%set_event_index (offset + 1)
else
call expr%set_event_index (1)
end if
end subroutine event_expr_increment_event_index
@ %def event_expr_set_event_index
@ %def event_expr_increment_event_index
@ Fill the event expression: take the particle data and kinematics
from a [[particle_set]] object.
We allow the particle content to change for each event. Therefore, we set the
event variables each time.
Also increment the event index; initialize it if necessary.
<<Subevt expr: event expr: TBP>>=
procedure :: fill_subevt => event_expr_fill_subevt
<<Subevt expr: sub interfaces>>=
module subroutine event_expr_fill_subevt (expr, particle_set)
class(event_expr_t), intent(inout) :: expr
type(particle_set_t), intent(in) :: particle_set
end subroutine event_expr_fill_subevt
<<Subevt expr: procedures>>=
module subroutine event_expr_fill_subevt (expr, particle_set)
class(event_expr_t), intent(inout) :: expr
type(particle_set_t), intent(in) :: particle_set
call particle_set%to_subevt (expr%subevt_t, expr%colorize_subevt)
expr%sqrts_hat = expr%get_sqrts_hat ()
expr%n_in = expr%get_n_in ()
expr%n_out = expr%get_n_out ()
expr%n_tot = expr%n_in + expr%n_out
expr%subevt_filled = .true.
end subroutine event_expr_fill_subevt
@ %def event_expr_fill_subevt
@ Evaluate, if the event passes the selection. For absent expressions we take
default values.
<<Subevt expr: event expr: TBP>>=
procedure :: evaluate => event_expr_evaluate
<<Subevt expr: sub interfaces>>=
module subroutine event_expr_evaluate &
(expr, passed, reweight, analysis_flag)
class(event_expr_t), intent(inout) :: expr
logical, intent(out) :: passed
real(default), intent(out) :: reweight
logical, intent(out) :: analysis_flag
end subroutine event_expr_evaluate
<<Subevt expr: procedures>>=
module subroutine event_expr_evaluate (expr, passed, reweight, analysis_flag)
class(event_expr_t), intent(inout) :: expr
logical, intent(out) :: passed
real(default), intent(out) :: reweight
logical, intent(out) :: analysis_flag
call expr%base_evaluate (passed)
if (passed) then
if (expr%has_reweight) then
call expr%reweight%evaluate ()
if (expr%reweight%is_known ()) then
reweight = expr%reweight%get_real ()
else
call msg_error ("Evaluate reweight expression: &
&result undefined")
reweight = 0
end if
else
reweight = 1
end if
if (expr%has_analysis) then
call expr%analysis%evaluate ()
if (expr%analysis%is_known ()) then
analysis_flag = expr%analysis%get_log ()
else
call msg_error ("Evaluate analysis expression: &
&result undefined")
analysis_flag = .false.
end if
else
analysis_flag = .true.
end if
end if
end subroutine event_expr_evaluate
@ %def event_expr_evaluate
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Parton states}
A [[parton_state_t]] object contains the effective kinematics and
dynamics of an elementary partonic interaction, with or without the
beam/structure function state included. The type is abstract and has
two distinct extensions. The [[isolated_state_t]] extension describes
the isolated elementary interaction where the [[int_eff]] subobject
contains the complex transition amplitude, exclusive in all quantum
numbers. The particle content and kinematics describe the effective
partonic state. The [[connected_state_t]] extension contains the
partonic [[subevt]] and the expressions for cuts and scales which use
it.
In the isolated state, the effective partonic interaction may either
be identical to the hard interaction, in which case it is just a
pointer to the latter. Or it may involve a rearrangement of partons,
in which case we allocate it explicitly and flag this by
[[int_is_allocated]].
The [[trace]] evaluator contains the absolute square of the effective
transition amplitude matrix, summed over final states. It is also summed over
initial states, depending on the the beam setup allows. The result is used for
integration.
The [[matrix]] evaluator is the counterpart of [[trace]] which is kept
exclusive in all observable quantum numbers. The [[flows]] evaluator is
furthermore exclusive in colors, but neglecting all color interference. The
[[matrix]] and [[flows]] evaluators are filled only for sampling points that
become part of physical events.
Note: It would be natural to make the evaluators allocatable. The extra
[[has_XXX]] flags indicate whether evaluators are active, instead.
This module contains no unit tests. The tests are covered by the
[[processes]] module below.
<<[[parton_states.f90]]>>=
<<File header>>
module parton_states
<<Use kinds>>
use variables
use expr_base
use model_data
use flavors
use quantum_numbers
use state_matrices
use interactions
use evaluators
use beams
use sf_base
use prc_core
use subevt_expr
<<Standard module head>>
<<Parton states: public>>
<<Parton states: types>>
interface
<<Parton states: sub interfaces>>
end interface
end module parton_states
@ %def parton_states
@
<<[[parton_states_sub.f90]]>>=
<<File header>>
submodule (parton_states) parton_states_s
<<Use debug>>
use io_units
use format_utils, only: write_separator
use diagnostics
use lorentz
use subevents
use helicities
use colors
use polarizations
use process_constants
implicit none
contains
<<Parton states: procedures>>
end submodule parton_states_s
@ %def parton_states_s
@
\subsection{Abstract base type}
The common part are the evaluators, one for the trace (summed over all
quantum numbers), one for the transition matrix (summed only over
unobservable quantum numbers), and one for the flow distribution
(transition matrix without interferences, exclusive in color flow).
<<Parton states: types>>=
type, abstract :: parton_state_t
logical :: has_trace = .false.
logical :: has_matrix = .false.
logical :: has_flows = .false.
type(evaluator_t) :: trace
type(evaluator_t) :: matrix
type(evaluator_t) :: flows
contains
<<Parton states: parton state: TBP>>
end type parton_state_t
@ %def parton_state_t
@ The [[isolated_state_t]] extension contains the [[sf_chain_eff]] object
and the (hard) effective interaction [[int_eff]], separately, both are
implemented as a pointer. The evaluators (trace, matrix, flows) apply
to the hard interaction only.
If the effective interaction differs from the hard interaction, the
pointer is allocated explicitly. Analogously for [[sf_chain_eff]].
<<Parton states: public>>=
public :: isolated_state_t
<<Parton states: types>>=
type, extends (parton_state_t) :: isolated_state_t
logical :: sf_chain_is_allocated = .false.
type(sf_chain_instance_t), pointer :: sf_chain_eff => null ()
logical :: int_is_allocated = .false.
type(interaction_t), pointer :: int_eff => null ()
contains
<<Parton states: isolated state: TBP>>
end type isolated_state_t
@ %def isolated_state_t
@ The [[connected_state_t]] extension contains all data that enable
the evaluation of observables for the effective connected state. The
evaluators connect the (effective) structure-function chain and hard
interaction that were kept separate in the [[isolated_state_t]].
The [[flows_sf]] evaluator is an extended copy of the
structure-function
The [[expr]] subobject consists of the [[subevt]], a simple event record,
expressions for cuts etc.\ which refer to this record, and a [[var_list]]
which contains event-specific variables, linked to the process variable
list. Variables used within the expressions are looked up in [[var_list]].
<<Parton states: public>>=
public :: connected_state_t
<<Parton states: types>>=
type, extends (parton_state_t) :: connected_state_t
type(state_flv_content_t) :: state_flv
logical :: has_flows_sf = .false.
type(evaluator_t) :: flows_sf
logical :: has_expr = .false.
type(parton_expr_t) :: expr
contains
<<Parton states: connected state: TBP>>
end type connected_state_t
@ %def connected_state_t
@ Output: each evaluator is written only when it is active. The
[[sf_chain]] is only written if it is explicitly allocated.
<<Parton states: parton state: TBP>>=
procedure :: write => parton_state_write
<<Parton states: sub interfaces>>=
module subroutine parton_state_write (state, unit, testflag)
class(parton_state_t), intent(in) :: state
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
end subroutine parton_state_write
<<Parton states: procedures>>=
module subroutine parton_state_write (state, unit, testflag)
class(parton_state_t), intent(in) :: state
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
integer :: u
u = given_output_unit (unit)
select type (state)
class is (isolated_state_t)
if (state%sf_chain_is_allocated) then
call write_separator (u)
call state%sf_chain_eff%write (u)
end if
if (state%int_is_allocated) then
call write_separator (u)
write (u, "(1x,A)") &
"Effective interaction:"
call write_separator (u)
call state%int_eff%basic_write (u, testflag = testflag)
end if
class is (connected_state_t)
if (state%has_flows_sf) then
call write_separator (u)
write (u, "(1x,A)") &
"Evaluator (extension of the beam evaluator &
&with color contractions):"
call write_separator (u)
call state%flows_sf%write (u, testflag = testflag)
end if
end select
if (state%has_trace) then
call write_separator (u)
write (u, "(1x,A)") &
"Evaluator (trace of the squared transition matrix):"
call write_separator (u)
call state%trace%write (u, testflag = testflag)
end if
if (state%has_matrix) then
call write_separator (u)
write (u, "(1x,A)") &
"Evaluator (squared transition matrix):"
call write_separator (u)
call state%matrix%write (u, testflag = testflag)
end if
if (state%has_flows) then
call write_separator (u)
write (u, "(1x,A)") &
"Evaluator (squared color-flow matrix):"
call write_separator (u)
call state%flows%write (u, testflag = testflag)
end if
select type (state)
class is (connected_state_t)
if (state%has_expr) then
call write_separator (u)
call state%expr%write (u)
end if
end select
end subroutine parton_state_write
@ %def parton_state_write
@ Finalize interaction and evaluators, but only if allocated.
<<Parton states: parton state: TBP>>=
procedure :: final => parton_state_final
<<Parton states: sub interfaces>>=
module subroutine parton_state_final (state)
class(parton_state_t), intent(inout) :: state
end subroutine parton_state_final
<<Parton states: procedures>>=
module subroutine parton_state_final (state)
class(parton_state_t), intent(inout) :: state
if (state%has_flows) then
call state%flows%final ()
state%has_flows = .false.
end if
if (state%has_matrix) then
call state%matrix%final ()
state%has_matrix = .false.
end if
if (state%has_trace) then
call state%trace%final ()
state%has_trace = .false.
end if
select type (state)
class is (connected_state_t)
if (state%has_flows_sf) then
call state%flows_sf%final ()
state%has_flows_sf = .false.
end if
call state%expr%final ()
class is (isolated_state_t)
if (state%int_is_allocated) then
call state%int_eff%final ()
deallocate (state%int_eff)
state%int_is_allocated = .false.
end if
if (state%sf_chain_is_allocated) then
call state%sf_chain_eff%final ()
end if
end select
end subroutine parton_state_final
@ %def parton_state_final
@
\subsection{Common Initialization}
Initialize the isolated parton state. In this version, the
effective structure-function chain [[sf_chain_eff]] and the effective
interaction [[int_eff]] both are trivial pointers to the seed
structure-function chain and to the hard interaction, respectively.
<<Parton states: isolated state: TBP>>=
procedure :: init => isolated_state_init
<<Parton states: sub interfaces>>=
module subroutine isolated_state_init (state, sf_chain, int)
class(isolated_state_t), intent(out) :: state
type(sf_chain_instance_t), intent(in), target :: sf_chain
type(interaction_t), intent(in), target :: int
end subroutine isolated_state_init
<<Parton states: procedures>>=
module subroutine isolated_state_init (state, sf_chain, int)
class(isolated_state_t), intent(out) :: state
type(sf_chain_instance_t), intent(in), target :: sf_chain
type(interaction_t), intent(in), target :: int
state%sf_chain_eff => sf_chain
state%int_eff => int
end subroutine isolated_state_init
@ %def isolated_state_init
@
\subsection{Evaluator initialization: isolated state}
Create an evaluator for the trace of the squared transition matrix.
The trace goes over all outgoing quantum numbers. Whether we trace
over incoming quantum numbers other than color, depends on the given
[[qn_mask_in]].
There are two options: explicitly computing the color factor table
([[use_cf]] false; [[nc]] defined), or taking the color factor
table from the hard matrix element data.
<<Parton states: isolated state: TBP>>=
procedure :: setup_square_trace => isolated_state_setup_square_trace
<<Parton states: sub interfaces>>=
module subroutine isolated_state_setup_square_trace (state, core, &
qn_mask_in, col, keep_fs_flavor)
class(isolated_state_t), intent(inout), target :: state
class(prc_core_t), intent(in) :: core
type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in
integer, intent(in), dimension(:), allocatable :: col
logical, intent(in) :: keep_fs_flavor
end subroutine isolated_state_setup_square_trace
<<Parton states: procedures>>=
module subroutine isolated_state_setup_square_trace (state, core, &
qn_mask_in, col, keep_fs_flavor)
class(isolated_state_t), intent(inout), target :: state
class(prc_core_t), intent(in) :: core
type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in
!!! Actually need allocatable attribute here for once because col might
!!! enter the subroutine non-allocated.
integer, intent(in), dimension(:), allocatable :: col
logical, intent(in) :: keep_fs_flavor
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
associate (data => core%data)
allocate (qn_mask (data%n_in + data%n_out))
qn_mask( : data%n_in) = &
quantum_numbers_mask (.false., .true., .false.) &
.or. qn_mask_in
qn_mask(data%n_in + 1 : ) = &
quantum_numbers_mask (.not. keep_fs_flavor, .true., .true.)
if (core%use_color_factors) then
call state%trace%init_square (state%int_eff, qn_mask, &
col_flow_index = data%cf_index, &
col_factor = data%color_factors, &
col_index_hi = col, &
nc = core%nc)
else
call state%trace%init_square (state%int_eff, qn_mask, nc = core%nc)
end if
end associate
state%has_trace = .true.
end subroutine isolated_state_setup_square_trace
@ %def isolated_state_setup_square_trace
@ Set up an identity-evaluator for the trace. This implies that [[me]]
is considered to be a squared amplitude, as for example for BLHA matrix
elements.
<<Parton states: isolated state: TBP>>=
procedure :: setup_identity_trace => isolated_state_setup_identity_trace
<<Parton states: sub interfaces>>=
module subroutine isolated_state_setup_identity_trace (state, core, &
qn_mask_in, keep_fs_flavors, keep_colors)
class(isolated_state_t), intent(inout), target :: state
class(prc_core_t), intent(in) :: core
type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in
logical, intent(in), optional :: keep_fs_flavors, keep_colors
end subroutine isolated_state_setup_identity_trace
<<Parton states: procedures>>=
module subroutine isolated_state_setup_identity_trace (state, core, &
qn_mask_in, keep_fs_flavors, keep_colors)
class(isolated_state_t), intent(inout), target :: state
class(prc_core_t), intent(in) :: core
type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in
logical, intent(in), optional :: keep_fs_flavors, keep_colors
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
logical :: fs_flv_flag, col_flag
fs_flv_flag = .true.; col_flag = .true.
if (present(keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors
if (present(keep_colors)) col_flag = .not. keep_colors
associate (data => core%data)
allocate (qn_mask (data%n_in + data%n_out))
qn_mask( : data%n_in) = &
quantum_numbers_mask (.false., col_flag, .false.) .or. qn_mask_in
qn_mask(data%n_in + 1 : ) = &
quantum_numbers_mask (fs_flv_flag, col_flag, .true.)
end associate
call state%int_eff%set_mask (qn_mask)
call state%trace%init_identity (state%int_eff)
state%has_trace = .true.
end subroutine isolated_state_setup_identity_trace
@ %def isolated_state_setup_identity_trace
@ Set up the evaluator for the transition matrix, exclusive in
helicities where this is requested.
For all unstable final-state particles we keep polarization according to the
applicable decay options. If the process is a decay itself, this applies also
to the initial state.
For all polarized final-state particles, we keep polarization including
off-diagonal entries. We drop helicity completely for unpolarized final-state
particles.
For the initial state, if the particle has not been handled yet, we
apply the provided [[qn_mask_in]] which communicates the beam properties.
<<Parton states: isolated state: TBP>>=
procedure :: setup_square_matrix => isolated_state_setup_square_matrix
<<Parton states: sub interfaces>>=
module subroutine isolated_state_setup_square_matrix &
(state, core, model, qn_mask_in, col)
class(isolated_state_t), intent(inout), target :: state
class(prc_core_t), intent(in) :: core
class(model_data_t), intent(in), target :: model
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
integer, dimension(:), intent(in) :: col
end subroutine isolated_state_setup_square_matrix
<<Parton states: procedures>>=
module subroutine isolated_state_setup_square_matrix &
(state, core, model, qn_mask_in, col)
class(isolated_state_t), intent(inout), target :: state
class(prc_core_t), intent(in) :: core
class(model_data_t), intent(in), target :: model
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
integer, dimension(:), intent(in) :: col
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
type(flavor_t), dimension(:), allocatable :: flv
integer :: i
logical :: helmask, helmask_hd
associate (data => core%data)
allocate (qn_mask (data%n_in + data%n_out))
allocate (flv (data%n_flv))
do i = 1, data%n_in + data%n_out
call flv%init (data%flv_state(i,:), model)
if ((data%n_in == 1 .or. i > data%n_in) &
.and. any (.not. flv%is_stable ())) then
helmask = all (flv%decays_isotropically ())
helmask_hd = all (flv%decays_diagonal ())
qn_mask(i) = quantum_numbers_mask (.false., .true., helmask, &
mask_hd = helmask_hd)
else if (i > data%n_in) then
helmask = all (.not. flv%is_polarized ())
qn_mask(i) = quantum_numbers_mask (.false., .true., helmask)
else
qn_mask(i) = quantum_numbers_mask (.false., .true., .false.) &
.or. qn_mask_in(i)
end if
end do
if (core%use_color_factors) then
call state%matrix%init_square (state%int_eff, qn_mask, &
col_flow_index = data%cf_index, &
col_factor = data%color_factors, &
col_index_hi = col, &
nc = core%nc)
else
call state%matrix%init_square (state%int_eff, &
qn_mask, &
nc = core%nc)
end if
end associate
state%has_matrix = .true.
end subroutine isolated_state_setup_square_matrix
@ %def isolated_state_setup_square_matrix
@ This procedure initializes the evaluator that computes the
contributions to color flows, neglecting color interference.
The incoming-particle mask can be used to sum over incoming flavor.
Helicity handling: see above.
<<Parton states: isolated state: TBP>>=
procedure :: setup_square_flows => isolated_state_setup_square_flows
<<Parton states: sub interfaces>>=
module subroutine isolated_state_setup_square_flows &
(state, core, model, qn_mask_in)
class(isolated_state_t), intent(inout), target :: state
class(prc_core_t), intent(in) :: core
class(model_data_t), intent(in), target :: model
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
end subroutine isolated_state_setup_square_flows
<<Parton states: procedures>>=
module subroutine isolated_state_setup_square_flows &
(state, core, model, qn_mask_in)
class(isolated_state_t), intent(inout), target :: state
class(prc_core_t), intent(in) :: core
class(model_data_t), intent(in), target :: model
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
type(flavor_t), dimension(:), allocatable :: flv
integer :: i
logical :: helmask, helmask_hd
associate (data => core%data)
allocate (qn_mask (data%n_in + data%n_out))
allocate (flv (data%n_flv))
do i = 1, data%n_in + data%n_out
call flv%init (data%flv_state(i,:), model)
if ((data%n_in == 1 .or. i > data%n_in) &
.and. any (.not. flv%is_stable ())) then
helmask = all (flv%decays_isotropically ())
helmask_hd = all (flv%decays_diagonal ())
qn_mask(i) = quantum_numbers_mask (.false., .false., helmask, &
mask_hd = helmask_hd)
else if (i > data%n_in) then
helmask = all (.not. flv%is_polarized ())
qn_mask(i) = quantum_numbers_mask (.false., .false., helmask)
else
qn_mask(i) = quantum_numbers_mask (.false., .false., .false.) &
.or. qn_mask_in(i)
end if
end do
call state%flows%init_square (state%int_eff, qn_mask, &
expand_color_flows = .true.)
end associate
state%has_flows = .true.
end subroutine isolated_state_setup_square_flows
@ %def isolated_state_setup_square_flows
@
\subsection{Evaluator initialization: connected state}
Set up a trace evaluator as a product of two evaluators (incoming state,
effective interaction). In the result, all quantum numbers are summed over.
If the optional [[int]] interaction is provided, use this for the
first factor in the convolution. Otherwise, use the final interaction
of the stored [[sf_chain]].
The [[resonant]] flag applies if we want to construct
a decay chain. The resonance property can propagate to the final
event output.
If an extended structure function is required [[requires_extended_sf]],
we have to not consider [[sub]] as a quantum number.
<<Parton states: connected state: TBP>>=
procedure :: setup_connected_trace => connected_state_setup_connected_trace
<<Parton states: sub interfaces>>=
module subroutine connected_state_setup_connected_trace &
(state, isolated, int, resonant, undo_helicities, &
keep_fs_flavors, requires_extended_sf)
class(connected_state_t), intent(inout), target :: state
type(isolated_state_t), intent(in), target :: isolated
type(interaction_t), intent(in), optional, target :: int
logical, intent(in), optional :: resonant
logical, intent(in), optional :: undo_helicities
logical, intent(in), optional :: keep_fs_flavors
logical, intent(in), optional :: requires_extended_sf
end subroutine connected_state_setup_connected_trace
<<Parton states: procedures>>=
module subroutine connected_state_setup_connected_trace &
(state, isolated, int, resonant, undo_helicities, &
keep_fs_flavors, requires_extended_sf)
class(connected_state_t), intent(inout), target :: state
type(isolated_state_t), intent(in), target :: isolated
type(interaction_t), intent(in), optional, target :: int
logical, intent(in), optional :: resonant
logical, intent(in), optional :: undo_helicities
logical, intent(in), optional :: keep_fs_flavors
logical, intent(in), optional :: requires_extended_sf
type(quantum_numbers_mask_t) :: mask
type(interaction_t), pointer :: src_int, beam_int
logical :: reduce, fs_flv_flag
if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
"connected_state_setup_connected_trace")
reduce = .false.; fs_flv_flag = .true.
if (present (undo_helicities)) reduce = undo_helicities
if (present (keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors
mask = quantum_numbers_mask (fs_flv_flag, .true., .true.)
if (present (int)) then
src_int => int
else
src_int => isolated%sf_chain_eff%get_out_int_ptr ()
end if
if (debug2_active (D_PROCESS_INTEGRATION)) then
call src_int%basic_write ()
end if
call state%trace%init_product (src_int, isolated%trace, &
qn_mask_conn = mask, &
qn_mask_rest = mask, &
connections_are_resonant = resonant, &
ignore_sub_for_qn = requires_extended_sf)
if (reduce) then
beam_int => isolated%sf_chain_eff%get_beam_int_ptr ()
call undo_qn_hel (beam_int, mask, beam_int%get_n_tot ())
call undo_qn_hel (src_int, mask, src_int%get_n_tot ())
call beam_int%set_matrix_element (cmplx (1, 0, default))
call src_int%set_matrix_element (cmplx (1, 0, default))
end if
state%has_trace = .true.
contains
subroutine undo_qn_hel (int_in, mask, n_tot)
type(interaction_t), intent(inout) :: int_in
type(quantum_numbers_mask_t), intent(in) :: mask
integer, intent(in) :: n_tot
type(quantum_numbers_mask_t), dimension(n_tot) :: mask_in
mask_in = mask
call int_in%set_mask (mask_in)
end subroutine undo_qn_hel
end subroutine connected_state_setup_connected_trace
@ %def connected_state_setup_connected_trace
@ Set up a matrix evaluator as a product of two evaluators (incoming
state, effective interation). In the intermediate state, color and
helicity is summed over. In the final state, we keep the quantum
numbers which are present in the original evaluators.
<<Parton states: connected state: TBP>>=
procedure :: setup_connected_matrix => connected_state_setup_connected_matrix
<<Parton states: sub interfaces>>=
module subroutine connected_state_setup_connected_matrix &
(state, isolated, int, resonant, qn_filter_conn)
class(connected_state_t), intent(inout), target :: state
type(isolated_state_t), intent(in), target :: isolated
type(interaction_t), intent(in), optional, target :: int
logical, intent(in), optional :: resonant
type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
end subroutine connected_state_setup_connected_matrix
<<Parton states: procedures>>=
module subroutine connected_state_setup_connected_matrix &
(state, isolated, int, resonant, qn_filter_conn)
class(connected_state_t), intent(inout), target :: state
type(isolated_state_t), intent(in), target :: isolated
type(interaction_t), intent(in), optional, target :: int
logical, intent(in), optional :: resonant
type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
type(quantum_numbers_mask_t) :: mask
type(interaction_t), pointer :: src_int
mask = quantum_numbers_mask (.false., .true., .true.)
if (present (int)) then
src_int => int
else
src_int => isolated%sf_chain_eff%get_out_int_ptr ()
end if
call state%matrix%init_product &
(src_int, isolated%matrix, mask, &
qn_filter_conn = qn_filter_conn, &
connections_are_resonant = resonant)
state%has_matrix = .true.
end subroutine connected_state_setup_connected_matrix
@ %def connected_state_setup_connected_matrix
@ Set up a matrix evaluator as a product of two evaluators (incoming
state, effective interation). In the intermediate state, only
helicity is summed over. In the final state, we keep the quantum
numbers which are present in the original evaluators.
If the optional [[int]] interaction is provided, use this for the
first factor in the convolution. Otherwise, use the final interaction
of the stored [[sf_chain]], after creating an intermediate interaction
that includes a correlated color state. We assume that for a
caller-provided [[int]], this is not necessary.
For fixed-order NLO differential distribution, we are interested at
the partonic level, no parton showering takes place as this would
demand for a proper matching. So, the flows in the [[connected_state]]
are not needed, and the color part will be masked for the interaction
coming from the [[sf_chain]]. The squared matrix elements coming from
the OLP provider at the moment do not come with flows anyhow. This
needs to be revised once the matching to the shower is completed.
<<Parton states: connected state: TBP>>=
procedure :: setup_connected_flows => connected_state_setup_connected_flows
<<Parton states: sub interfaces>>=
module subroutine connected_state_setup_connected_flows &
(state, isolated, int, resonant, qn_filter_conn, mask_color)
class(connected_state_t), intent(inout), target :: state
type(isolated_state_t), intent(in), target :: isolated
type(interaction_t), intent(in), optional, target :: int
logical, intent(in), optional :: resonant, mask_color
type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
end subroutine connected_state_setup_connected_flows
<<Parton states: procedures>>=
module subroutine connected_state_setup_connected_flows &
(state, isolated, int, resonant, qn_filter_conn, mask_color)
class(connected_state_t), intent(inout), target :: state
type(isolated_state_t), intent(in), target :: isolated
type(interaction_t), intent(in), optional, target :: int
logical, intent(in), optional :: resonant, mask_color
type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
type(quantum_numbers_mask_t) :: mask
type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_sf
type(interaction_t), pointer :: src_int
logical :: mask_c
mask_c = .false.
if (present (mask_color)) mask_c = mask_color
mask = quantum_numbers_mask (.false., .false., .true.)
if (present (int)) then
src_int => int
else
src_int => isolated%sf_chain_eff%get_out_int_ptr ()
call state%flows_sf%init_color_contractions (src_int)
state%has_flows_sf = .true.
src_int => state%flows_sf%interaction_t
if (mask_c) then
allocate (mask_sf (src_int%get_n_tot ()))
mask_sf = quantum_numbers_mask (.false., .true., .false.)
call src_int%reduce_state_matrix (mask_sf, keep_order = .true.)
end if
end if
call state%flows%init_product (src_int, isolated%flows, mask, &
qn_filter_conn = qn_filter_conn, &
connections_are_resonant = resonant)
state%has_flows = .true.
end subroutine connected_state_setup_connected_flows
@ %def connected_state_setup_connected_flows
@ Determine and store the flavor content for the connected state.
This queries the [[matrix]] evaluator component, which should hold the
requested flavor information.
<<Parton states: connected state: TBP>>=
procedure :: setup_state_flv => connected_state_setup_state_flv
<<Parton states: sub interfaces>>=
module subroutine connected_state_setup_state_flv (state, n_out_hard)
class(connected_state_t), intent(inout), target :: state
integer, intent(in) :: n_out_hard
end subroutine connected_state_setup_state_flv
<<Parton states: procedures>>=
module subroutine connected_state_setup_state_flv (state, n_out_hard)
class(connected_state_t), intent(inout), target :: state
integer, intent(in) :: n_out_hard
call state%matrix%get_flv_content (state%state_flv, n_out_hard)
end subroutine connected_state_setup_state_flv
@ %def connected_state_setup_state_flv
@ Return the current flavor state object.
<<Parton states: connected state: TBP>>=
procedure :: get_state_flv => connected_state_get_state_flv
<<Parton states: sub interfaces>>=
module function connected_state_get_state_flv (state) result (state_flv)
class(connected_state_t), intent(in) :: state
type(state_flv_content_t) :: state_flv
end function connected_state_get_state_flv
<<Parton states: procedures>>=
module function connected_state_get_state_flv (state) result (state_flv)
class(connected_state_t), intent(in) :: state
type(state_flv_content_t) :: state_flv
state_flv = state%state_flv
end function connected_state_get_state_flv
@ %def connected_state_get_state_flv
@
\subsection{Cuts and expressions}
Set up the [[subevt]] that corresponds to the connected interaction.
The index arrays refer to the interaction.
We assign the particles as follows: the beam particles are the first
two (decay process: one) entries in the trace evaluator. The incoming
partons are identified by their link to the outgoing partons of the
structure-function chain. The outgoing partons are those of the trace
evaluator, which include radiated partons during the
structure-function chain.
<<Parton states: connected state: TBP>>=
procedure :: setup_subevt => connected_state_setup_subevt
<<Parton states: sub interfaces>>=
module subroutine connected_state_setup_subevt &
(state, sf_chain, f_beam, f_in, f_out)
class(connected_state_t), intent(inout), target :: state
type(sf_chain_instance_t), intent(in), target :: sf_chain
type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
end subroutine connected_state_setup_subevt
<<Parton states: procedures>>=
module subroutine connected_state_setup_subevt &
(state, sf_chain, f_beam, f_in, f_out)
class(connected_state_t), intent(inout), target :: state
type(sf_chain_instance_t), intent(in), target :: sf_chain
type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
integer :: n_beam, n_in, n_out, n_vir, n_tot, i, j
integer, dimension(:), allocatable :: i_beam, i_in, i_out
integer :: sf_out_i
type(interaction_t), pointer :: sf_int
sf_int => sf_chain%get_out_int_ptr ()
n_beam = size (f_beam)
n_in = size (f_in)
n_out = size (f_out)
n_vir = state%trace%get_n_vir ()
n_tot = state%trace%get_n_tot ()
allocate (i_beam (n_beam), i_in (n_in), i_out (n_out))
i_beam = [(i, i = 1, n_beam)]
do j = 1, n_in
sf_out_i = sf_chain%get_out_i (j)
i_in(j) = interaction_find_link &
(state%trace%interaction_t, sf_int, sf_out_i)
end do
i_out = [(i, i = n_vir + 1, n_tot)]
call state%expr%setup_subevt (state%trace%interaction_t, &
i_beam, i_in, i_out, f_beam, f_in, f_out)
state%has_expr = .true.
end subroutine connected_state_setup_subevt
@ %def connected_state_setup_subevt
<<Parton states: connected state: TBP>>=
procedure :: renew_flv_content_subevt => &
connected_state_renew_flv_content_subevt
<<Parton states: sub interfaces>>=
module subroutine connected_state_renew_flv_content_subevt &
(state, sf_chain, f_beam, f_in, f_out)
class(connected_state_t), intent(inout), target :: state
type(sf_chain_instance_t), intent(in), target :: sf_chain
type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
end subroutine connected_state_renew_flv_content_subevt
<<Parton states: procedures>>=
module subroutine connected_state_renew_flv_content_subevt &
(state, sf_chain, f_beam, f_in, f_out)
class(connected_state_t), intent(inout), target :: state
type(sf_chain_instance_t), intent(in), target :: sf_chain
type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
integer :: n_beam, n_in, n_out, n_vir, n_tot, i, j
integer, dimension(:), allocatable :: i_beam, i_in, i_out
integer :: sf_out_i
type(interaction_t), pointer :: sf_int
sf_int => sf_chain%get_out_int_ptr ()
n_beam = size (f_beam)
n_in = size (f_in)
n_out = size (f_out)
n_vir = state%trace%get_n_vir ()
n_tot = state%trace%get_n_tot ()
allocate (i_beam (n_beam), i_in (n_in), i_out (n_out))
i_beam = [(i, i = 1, n_beam)]
do j = 1, n_in
sf_out_i = sf_chain%get_out_i (j)
i_in(j) = interaction_find_link &
(state%trace%interaction_t, sf_int, sf_out_i)
end do
i_out = [(i, i = n_vir + 1, n_tot)]
call state%expr%renew_flv_content_subevt (state%trace%interaction_t, &
i_beam, i_in, i_out, f_beam, f_in, f_out)
state%has_expr = .true.
end subroutine connected_state_renew_flv_content_subevt
@ %def connected_state_setup_subevt
@ Initialize the variable list specific for this state/term. We insert event
variables ([[sqrts_hat]]) and link the process variable list. The variable
list acquires pointers to subobjects of [[state]], which must therefore have a
[[target]] attribute.
<<Parton states: connected state: TBP>>=
procedure :: setup_var_list => connected_state_setup_var_list
<<Parton states: sub interfaces>>=
module subroutine connected_state_setup_var_list &
(state, process_var_list, beam_data)
class(connected_state_t), intent(inout), target :: state
type(var_list_t), intent(in), target :: process_var_list
type(beam_data_t), intent(in) :: beam_data
end subroutine connected_state_setup_var_list
<<Parton states: procedures>>=
module subroutine connected_state_setup_var_list &
(state, process_var_list, beam_data)
class(connected_state_t), intent(inout), target :: state
type(var_list_t), intent(in), target :: process_var_list
type(beam_data_t), intent(in) :: beam_data
call state%expr%setup_vars (beam_data%get_sqrts ())
call state%expr%link_var_list (process_var_list)
end subroutine connected_state_setup_var_list
@ %def connected_state_setup_var_list
@ Allocate the cut expression etc.
<<Parton states: connected state: TBP>>=
procedure :: setup_cuts => connected_state_setup_cuts
procedure :: setup_scale => connected_state_setup_scale
procedure :: setup_fac_scale => connected_state_setup_fac_scale
procedure :: setup_ren_scale => connected_state_setup_ren_scale
procedure :: setup_weight => connected_state_setup_weight
<<Parton states: sub interfaces>>=
module subroutine connected_state_setup_cuts (state, ef_cuts)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_cuts
end subroutine connected_state_setup_cuts
module subroutine connected_state_setup_scale (state, ef_scale)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_scale
end subroutine connected_state_setup_scale
module subroutine connected_state_setup_fac_scale (state, ef_fac_scale)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_fac_scale
end subroutine connected_state_setup_fac_scale
module subroutine connected_state_setup_ren_scale (state, ef_ren_scale)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_ren_scale
end subroutine connected_state_setup_ren_scale
module subroutine connected_state_setup_weight (state, ef_weight)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_weight
end subroutine connected_state_setup_weight
<<Parton states: procedures>>=
module subroutine connected_state_setup_cuts (state, ef_cuts)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_cuts
call state%expr%setup_selection (ef_cuts)
end subroutine connected_state_setup_cuts
module subroutine connected_state_setup_scale (state, ef_scale)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_scale
call state%expr%setup_scale (ef_scale)
end subroutine connected_state_setup_scale
module subroutine connected_state_setup_fac_scale (state, ef_fac_scale)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_fac_scale
call state%expr%setup_fac_scale (ef_fac_scale)
end subroutine connected_state_setup_fac_scale
module subroutine connected_state_setup_ren_scale (state, ef_ren_scale)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_ren_scale
call state%expr%setup_ren_scale (ef_ren_scale)
end subroutine connected_state_setup_ren_scale
module subroutine connected_state_setup_weight (state, ef_weight)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_weight
call state%expr%setup_weight (ef_weight)
end subroutine connected_state_setup_weight
@ %def connected_state_setup_expressions
@ Reset the expression object: invalidate the subevt.
<<Parton states: connected state: TBP>>=
procedure :: reset_expressions => connected_state_reset_expressions
<<Parton states: sub interfaces>>=
module subroutine connected_state_reset_expressions (state)
class(connected_state_t), intent(inout) :: state
end subroutine connected_state_reset_expressions
<<Parton states: procedures>>=
module subroutine connected_state_reset_expressions (state)
class(connected_state_t), intent(inout) :: state
if (state%has_expr) call state%expr%reset_contents ()
end subroutine connected_state_reset_expressions
@ %def connected_state_reset_expressions
@
\subsection{Evaluation}
Transfer momenta to the trace evaluator and fill the [[subevt]] with
this effective kinematics, if applicable.
Note: we may want to apply a boost for the [[subevt]].
<<Parton states: parton state: TBP>>=
procedure :: receive_kinematics => parton_state_receive_kinematics
<<Parton states: sub interfaces>>=
module subroutine parton_state_receive_kinematics (state)
class(parton_state_t), intent(inout), target :: state
end subroutine parton_state_receive_kinematics
<<Parton states: procedures>>=
module subroutine parton_state_receive_kinematics (state)
class(parton_state_t), intent(inout), target :: state
if (state%has_trace) then
call state%trace%receive_momenta ()
select type (state)
class is (connected_state_t)
if (state%has_expr) then
call state%expr%fill_subevt (state%trace%interaction_t)
end if
end select
end if
end subroutine parton_state_receive_kinematics
@ %def parton_state_receive_kinematics
@ Recover kinematics: We assume that the trace evaluator is filled
with momenta. Send those momenta back to the sources, then fill the
variables and subevent as above.
The incoming momenta of the connected state are not connected to the
isolated state but to the beam interaction. Therefore, the incoming
momenta within the isolated state do not become defined, yet.
Instead, we reconstruct the beam (and ISR) momentum configuration.
<<Parton states: parton state: TBP>>=
procedure :: send_kinematics => parton_state_send_kinematics
<<Parton states: sub interfaces>>=
module subroutine parton_state_send_kinematics (state)
class(parton_state_t), intent(inout), target :: state
end subroutine parton_state_send_kinematics
<<Parton states: procedures>>=
module subroutine parton_state_send_kinematics (state)
class(parton_state_t), intent(inout), target :: state
if (state%has_trace) then
call state%trace%send_momenta ()
select type (state)
class is (connected_state_t)
call state%expr%fill_subevt (state%trace%interaction_t)
end select
end if
end subroutine parton_state_send_kinematics
@ %def parton_state_send_kinematics
@ Evaluate the expressions. The routine evaluates first the cut expression.
If the event passes, it evaluates the other expressions. Where no expressions
are defined, default values are inserted.
<<Parton states: connected state: TBP>>=
procedure :: evaluate_expressions => connected_state_evaluate_expressions
<<Parton states: sub interfaces>>=
module subroutine connected_state_evaluate_expressions (state, passed, &
scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation)
class(connected_state_t), intent(inout) :: state
logical, intent(out) :: passed
real(default), intent(out) :: scale, weight
real(default), intent(out), allocatable :: fac_scale, ren_scale
real(default), intent(in), allocatable, optional :: scale_forced
logical, intent(in), optional :: force_evaluation
end subroutine connected_state_evaluate_expressions
<<Parton states: procedures>>=
module subroutine connected_state_evaluate_expressions (state, passed, &
scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation)
class(connected_state_t), intent(inout) :: state
logical, intent(out) :: passed
real(default), intent(out) :: scale, weight
real(default), intent(out), allocatable :: fac_scale, ren_scale
real(default), intent(in), allocatable, optional :: scale_forced
logical, intent(in), optional :: force_evaluation
if (state%has_expr) then
call state%expr%evaluate (passed, scale, fac_scale, ren_scale, weight, &
scale_forced, force_evaluation)
end if
end subroutine connected_state_evaluate_expressions
@ %def connected_state_evaluate_expressions
@ Evaluate the structure-function chain, if it is allocated
explicitly. The argument is the factorization scale.
If the chain is merely a pointer, the chain should already be
evaluated at this point.
<<Parton states: isolated state: TBP>>=
procedure :: evaluate_sf_chain => isolated_state_evaluate_sf_chain
<<Parton states: sub interfaces>>=
module subroutine isolated_state_evaluate_sf_chain (state, fac_scale)
class(isolated_state_t), intent(inout) :: state
real(default), intent(in) :: fac_scale
end subroutine isolated_state_evaluate_sf_chain
<<Parton states: procedures>>=
module subroutine isolated_state_evaluate_sf_chain (state, fac_scale)
class(isolated_state_t), intent(inout) :: state
real(default), intent(in) :: fac_scale
if (state%sf_chain_is_allocated) &
call state%sf_chain_eff%evaluate (fac_scale)
end subroutine isolated_state_evaluate_sf_chain
@ %def isolated_state_evaluate_sf_chain
@ Evaluate the trace.
<<Parton states: parton state: TBP>>=
procedure :: evaluate_trace => parton_state_evaluate_trace
<<Parton states: sub interfaces>>=
module subroutine parton_state_evaluate_trace (state)
class(parton_state_t), intent(inout) :: state
end subroutine parton_state_evaluate_trace
<<Parton states: procedures>>=
module subroutine parton_state_evaluate_trace (state)
class(parton_state_t), intent(inout) :: state
if (state%has_trace) call state%trace%evaluate ()
end subroutine parton_state_evaluate_trace
@ %def parton_state_evaluate_trace
<<Parton states: parton state: TBP>>=
procedure :: evaluate_matrix => parton_state_evaluate_matrix
<<Parton states: sub interfaces>>=
module subroutine parton_state_evaluate_matrix (state)
class(parton_state_t), intent(inout) :: state
end subroutine parton_state_evaluate_matrix
<<Parton states: procedures>>=
module subroutine parton_state_evaluate_matrix (state)
class(parton_state_t), intent(inout) :: state
if (state%has_matrix) call state%matrix%evaluate ()
end subroutine parton_state_evaluate_matrix
@ %def parton_state_evaluate_matrix
@ Evaluate the extra evaluators that we need for physical events.
<<Parton states: parton state: TBP>>=
procedure :: evaluate_event_data => parton_state_evaluate_event_data
<<Parton states: sub interfaces>>=
module subroutine parton_state_evaluate_event_data (state, only_momenta)
class(parton_state_t), intent(inout) :: state
logical, intent(in), optional :: only_momenta
end subroutine parton_state_evaluate_event_data
<<Parton states: procedures>>=
module subroutine parton_state_evaluate_event_data (state, only_momenta)
class(parton_state_t), intent(inout) :: state
logical, intent(in), optional :: only_momenta
logical :: only_mom
only_mom = .false.; if (present (only_momenta)) only_mom = only_momenta
select type (state)
type is (connected_state_t)
if (state%has_flows_sf) then
call state%flows_sf%receive_momenta ()
if (.not. only_mom) call state%flows_sf%evaluate ()
end if
end select
if (state%has_matrix) then
call state%matrix%receive_momenta ()
if (.not. only_mom) call state%matrix%evaluate ()
end if
if (state%has_flows) then
call state%flows%receive_momenta ()
if (.not. only_mom) call state%flows%evaluate ()
end if
end subroutine parton_state_evaluate_event_data
@ %def parton_state_evaluate_event_data
@ Normalize the helicity density matrix by its trace, i.e., factor out
the trace and put it into an overall normalization factor. The trace
and flow evaluators are unchanged.
<<Parton states: parton state: TBP>>=
procedure :: normalize_matrix_by_trace => &
parton_state_normalize_matrix_by_trace
<<Parton states: sub interfaces>>=
module subroutine parton_state_normalize_matrix_by_trace (state)
class(parton_state_t), intent(inout) :: state
end subroutine parton_state_normalize_matrix_by_trace
<<Parton states: procedures>>=
module subroutine parton_state_normalize_matrix_by_trace (state)
class(parton_state_t), intent(inout) :: state
if (state%has_matrix) call state%matrix%normalize_by_trace ()
end subroutine parton_state_normalize_matrix_by_trace
@ %def parton_state_normalize_matrix_by_trace
@
\subsection{Accessing the state}
Three functions return a pointer to the event-relevant interactions.
<<Parton states: parton state: TBP>>=
procedure :: get_trace_int_ptr => parton_state_get_trace_int_ptr
procedure :: get_matrix_int_ptr => parton_state_get_matrix_int_ptr
procedure :: get_flows_int_ptr => parton_state_get_flows_int_ptr
<<Parton states: sub interfaces>>=
module function parton_state_get_trace_int_ptr (state) result (ptr)
class(parton_state_t), intent(in), target :: state
type(interaction_t), pointer :: ptr
end function parton_state_get_trace_int_ptr
module function parton_state_get_matrix_int_ptr (state) result (ptr)
class(parton_state_t), intent(in), target :: state
type(interaction_t), pointer :: ptr
end function parton_state_get_matrix_int_ptr
module function parton_state_get_flows_int_ptr (state) result (ptr)
class(parton_state_t), intent(in), target :: state
type(interaction_t), pointer :: ptr
end function parton_state_get_flows_int_ptr
<<Parton states: procedures>>=
module function parton_state_get_trace_int_ptr (state) result (ptr)
class(parton_state_t), intent(in), target :: state
type(interaction_t), pointer :: ptr
if (state%has_trace) then
ptr => state%trace%interaction_t
else
ptr => null ()
end if
end function parton_state_get_trace_int_ptr
module function parton_state_get_matrix_int_ptr (state) result (ptr)
class(parton_state_t), intent(in), target :: state
type(interaction_t), pointer :: ptr
if (state%has_matrix) then
ptr => state%matrix%interaction_t
else
ptr => null ()
end if
end function parton_state_get_matrix_int_ptr
module function parton_state_get_flows_int_ptr (state) result (ptr)
class(parton_state_t), intent(in), target :: state
type(interaction_t), pointer :: ptr
if (state%has_flows) then
ptr => state%flows%interaction_t
else
ptr => null ()
end if
end function parton_state_get_flows_int_ptr
@ %def parton_state_get_trace_int_ptr
@ %def parton_state_get_matrix_int_ptr
@ %def parton_state_get_flows_int_ptr
@ Return the indices of the beam particles and the outgoing particles within
the trace (and thus, matrix and flows) evaluator, respectively.
<<Parton states: connected state: TBP>>=
procedure :: get_beam_index => connected_state_get_beam_index
procedure :: get_in_index => connected_state_get_in_index
<<Parton states: sub interfaces>>=
module subroutine connected_state_get_beam_index (state, i_beam)
class(connected_state_t), intent(in) :: state
integer, dimension(:), intent(out) :: i_beam
end subroutine connected_state_get_beam_index
module subroutine connected_state_get_in_index (state, i_in)
class(connected_state_t), intent(in) :: state
integer, dimension(:), intent(out) :: i_in
end subroutine connected_state_get_in_index
<<Parton states: procedures>>=
module subroutine connected_state_get_beam_index (state, i_beam)
class(connected_state_t), intent(in) :: state
integer, dimension(:), intent(out) :: i_beam
call state%expr%get_beam_index (i_beam)
end subroutine connected_state_get_beam_index
module subroutine connected_state_get_in_index (state, i_in)
class(connected_state_t), intent(in) :: state
integer, dimension(:), intent(out) :: i_in
call state%expr%get_in_index (i_in)
end subroutine connected_state_get_in_index
@ %def connected_state_get_beam_index
@ %def connected_state_get_in_index
@
<<Parton states: public>>=
public :: refill_evaluator
<<Parton states: sub interfaces>>=
module subroutine refill_evaluator (sqme, qn, flv_index, evaluator)
complex(default), intent(in), dimension(:) :: sqme
type(quantum_numbers_t), intent(in), dimension(:,:) :: qn
integer, intent(in), dimension(:), optional :: flv_index
type(evaluator_t), intent(inout) :: evaluator
end subroutine refill_evaluator
<<Parton states: procedures>>=
module subroutine refill_evaluator (sqme, qn, flv_index, evaluator)
complex(default), intent(in), dimension(:) :: sqme
type(quantum_numbers_t), intent(in), dimension(:,:) :: qn
integer, intent(in), dimension(:), optional :: flv_index
type(evaluator_t), intent(inout) :: evaluator
integer :: i, i_flv
do i = 1, size (sqme)
if (present (flv_index)) then
i_flv = flv_index(i)
else
i_flv = i
end if
call evaluator%add_to_matrix_element (qn(:,i_flv), sqme(i), &
match_only_flavor = .true.)
end do
end subroutine refill_evaluator
@ %def refill_evaluator
@ Return the number of outgoing (hard) particles for the state.
<<Parton states: parton state: TBP>>=
procedure :: get_n_out => parton_state_get_n_out
<<Parton states: sub interfaces>>=
module function parton_state_get_n_out (state) result (n)
class(parton_state_t), intent(in), target :: state
integer :: n
end function parton_state_get_n_out
<<Parton states: procedures>>=
module function parton_state_get_n_out (state) result (n)
class(parton_state_t), intent(in), target :: state
integer :: n
n = state%trace%get_n_out ()
end function parton_state_get_n_out
@ %def parton_state_get_n_out
@
\subsection{Unit tests}
<<[[parton_states_ut.f90]]>>=
<<File header>>
module parton_states_ut
use unit_tests
use parton_states_uti
<<Standard module head>>
<<Parton states: public test>>
contains
<<Parton states: test driver>>
end module parton_states_ut
@ %def parton_states_ut
<<[[parton_states_uti.f90]]>>=
<<File header>>
module parton_states_uti
<<Use kinds>>
<<Use strings>>
use constants, only: zero
use numeric_utils
use flavors
use colors
use helicities
use quantum_numbers
use sf_base, only: sf_chain_instance_t
use state_matrices, only: state_matrix_t
use prc_template_me, only: prc_template_me_t
use interactions, only: interaction_t
use models, only: model_t, create_test_model
use parton_states
<<Standard module head>>
<<Parton states: test declarations>>
contains
<<Parton states: tests>>
end module parton_states_uti
@ %def parton_states_uti
@
<<Parton states: public test>>=
public :: parton_states_test
<<Parton states: test driver>>=
subroutine parton_states_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Parton states: execute tests>>
end subroutine parton_states_test
@ %def parton_states_test
@
\subsubsection{Test a simple isolated state}
<<Parton states: execute tests>>=
call test (parton_states_1, "parton_states_1", &
"Create a 2 -> 2 isolated state and compute trace", &
u, results)
<<Parton states: test declarations>>=
public :: parton_states_1
<<Parton states: tests>>=
subroutine parton_states_1 (u)
integer, intent(in) :: u
type(state_matrix_t), allocatable :: state
type(flavor_t), dimension(2) :: flv_in
type(flavor_t), dimension(2) :: flv_out1, flv_out2
type(flavor_t), dimension(4) :: flv_tot
type(helicity_t), dimension(4) :: hel
type(color_t), dimension(4) :: col
integer :: h1, h2, h3, h4
integer :: f
integer :: i
type(quantum_numbers_t), dimension(4) :: qn
type(prc_template_me_t) :: core
type(sf_chain_instance_t), target :: sf_chain
type(interaction_t), target :: int
type(isolated_state_t) :: isolated_state
integer :: n_states = 0
integer, dimension(:), allocatable :: col_flow_index
type(quantum_numbers_mask_t), dimension(2) :: qn_mask
integer, dimension(8) :: i_allowed_states
complex(default), dimension(8) :: me
complex(default) :: me_check_tot, me_check_1, me_check_2, me2
logical :: tmp1, tmp2
type(model_t), pointer :: test_model => null ()
write (u, "(A)") "* Test output: parton_states_1"
write (u, "(A)") "* Purpose: Test the standard parton states"
write (u, "(A)")
call flv_in%init ([11, -11])
call flv_out1%init ([1, -1])
call flv_out2%init ([2, -2])
write (u, "(A)") "* Using incoming flavors: "
call flavor_write_array (flv_in, u)
write (u, "(A)") "* Two outgoing flavor structures: "
call flavor_write_array (flv_out1, u)
call flavor_write_array (flv_out2, u)
write (u, "(A)") "* Initialize state matrix"
allocate (state)
call state%init ()
write (u, "(A)") "* Fill state matrix"
call col(3)%init ([1])
call col(4)%init ([-1])
do f = 1, 2
do h1 = -1, 1, 2
do h2 = -1, 1, 2
do h3 = -1, 1, 2
do h4 = -1, 1, 2
n_states = n_states + 1
call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4])
if (f == 1) then
flv_tot = [flv_in, flv_out1]
else
flv_tot = [flv_in, flv_out2]
end if
call qn%init (flv_tot, col, hel)
call state%add_state (qn)
end do
end do
end do
end do
end do
!!! Two flavors, one color flow, 2 x 2 x 2 x 2 helicity configurations
!!! -> 32 states.
write (u, "(A)")
write (u, "(A,I2)") "* Generated number of states: ", n_states
call state%freeze ()
!!! Indices of the helicity configurations which are non-zero
i_allowed_states = [6, 7, 10, 11, 22, 23, 26, 27]
me = [cmplx (-1.89448E-5_default, 9.94456E-7_default, default), &
cmplx (-8.37887E-2_default, 4.30842E-3_default, default), &
cmplx (-1.99997E-1_default, -1.01985E-2_default, default), &
cmplx ( 1.79717E-5_default, 9.27038E-7_default, default), &
cmplx (-1.74859E-5_default, 8.78819E-7_default, default), &
cmplx ( 1.67577E-1_default, -8.61683E-3_default, default), &
cmplx ( 2.41331E-1_default, 1.23306E-2_default, default), &
cmplx (-3.59435E-5_default, -1.85407E-6_default, default)]
me_check_tot = cmplx (zero, zero, default)
me_check_1 = cmplx (zero, zero, default)
me_check_2 = cmplx (zero, zero, default)
do i = 1, 8
me2 = me(i) * conjg (me(i))
me_check_tot = me_check_tot + me2
if (i < 5) then
me_check_1 = me_check_1 + me2
else
me_check_2 = me_check_2 + me2
end if
call state%set_matrix_element (i_allowed_states(i), me(i))
end do
!!! Do not forget the color factor
me_check_tot = 3._default * me_check_tot
me_check_1 = 3._default * me_check_1
me_check_2 = 3._default * me_check_2
write (u, "(A)")
write (u, "(A)") "* Setup interaction"
call int%basic_init (2, 0, 2, set_relations = .true.)
call int%set_state_matrix (state)
core%data%n_in = 2; core%data%n_out = 2
core%data%n_flv = 2
allocate (core%data%flv_state (4, 2))
core%data%flv_state (1, :) = [11, 11]
core%data%flv_state (2, :) = [-11, -11]
core%data%flv_state (3, :) = [1, 2]
core%data%flv_state (4, :) = [-1, -2]
core%use_color_factors = .false.
core%nc = 3
write (u, "(A)") "* Init isolated state"
call isolated_state%init (sf_chain, int)
!!! There is only one color flow.
allocate (col_flow_index (n_states)); col_flow_index = 1
call qn_mask%init (.false., .false., .true., mask_cg = .false.)
write (u, "(A)") "* Give a trace to the isolated state"
call isolated_state%setup_square_trace (core, qn_mask, col_flow_index, .false.)
call isolated_state%evaluate_trace ()
write (u, "(A)")
write (u, "(A)", advance = "no") "* Squared matrix element correct: "
write (u, "(L1)") nearly_equal (me_check_tot, &
isolated_state%trace%get_matrix_element (1), rel_smallness = 0.00001_default)
write (u, "(A)") "* Give a matrix to the isolated state"
call create_test_model (var_str ("SM"), test_model)
call isolated_state%setup_square_matrix (core, test_model, qn_mask, col_flow_index)
call isolated_state%evaluate_matrix ()
write (u, "(A)") "* Sub-matrixelements correct: "
tmp1 = nearly_equal (me_check_1, &
isolated_state%matrix%get_matrix_element (1), rel_smallness = 0.00001_default)
tmp2 = nearly_equal (me_check_2, &
isolated_state%matrix%get_matrix_element (2), rel_smallness = 0.00001_default)
write (u, "(A,L1,A,L1)") "* 1: ", tmp1, ", 2: ", tmp2
write (u, "(A)") "* Test output end: parton_states_1"
end subroutine parton_states_1
@ %def parton_states_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Process component management}
This module contains tools for managing and combining process
components and matrix-element code and values, acting at a level below
the actual process definition.
\subsection{Abstract base type}
The types introduced here are abstract base types.
<<[[pcm_base.f90]]>>=
<<File header>>
module pcm_base
<<Use kinds>>
<<Use strings>>
use os_interface, only: os_data_t
use process_libraries, only: process_library_t
use prc_core_def
use prc_core
use variables, only: var_list_t
use mappings, only: mapping_defaults_t
use phs_base, only: phs_config_t
use phs_forests, only: phs_parameters_t
use mci_base, only: mci_t
use model_data, only: model_data_t
use models, only: model_t
use blha_config, only: blha_master_t
use blha_olp_interfaces, only: blha_template_t
use process_config
use process_mci, only: process_mci_entry_t
<<Standard module head>>
<<PCM base: public>>
<<PCM base: parameters>>
<<PCM base: types>>
<<PCM base: interfaces>>
interface
<<PCM base: sub interfaces>>
end interface
end module pcm_base
@ %def pcm_base
@
<<[[pcm_base_sub.f90]]>>=
<<File header>>
submodule (pcm_base) pcm_base_s
use io_units
use diagnostics
use format_utils, only: write_integer_array
use format_utils, only: write_separator
use physics_defs, only: BORN, NLO_REAL
implicit none
contains
<<PCM base: procedures>>
end submodule pcm_base_s
@ %def pcm_base_s
@
\subsection{Core management}
This object holds information about the cores used by the components
and allocates the corresponding manager instance.
[[i_component]] is the index of the process component which this core belongs
to. The pointer to the core definition is a convenient help in configuring
the core itself.
We allow for a [[blha_config]] configuration object that covers BLHA cores.
The BLHA standard is suitable generic to warrant support outside of specific
type extension (i.e., applies to LO and NLO if requested). The BLHA
configuration is allocated only if the core requires it.
<<PCM base: public>>=
public :: core_entry_t
<<PCM base: types>>=
type :: core_entry_t
integer :: i_component = 0
logical :: active = .false.
class(prc_core_def_t), pointer :: core_def => null ()
type(blha_template_t), allocatable :: blha_config
class(prc_core_t), allocatable :: core
contains
<<PCM base: core entry: TBP>>
end type core_entry_t
@ %def core_entry_t
@
<<PCM base: core entry: TBP>>=
procedure :: get_core_ptr => core_entry_get_core_ptr
<<PCM base: sub interfaces>>=
module function core_entry_get_core_ptr (core_entry) result (core)
class(core_entry_t), intent(in), target :: core_entry
class(prc_core_t), pointer :: core
end function core_entry_get_core_ptr
<<PCM base: procedures>>=
module function core_entry_get_core_ptr (core_entry) result (core)
class(core_entry_t), intent(in), target :: core_entry
class(prc_core_t), pointer :: core
if (allocated (core_entry%core)) then
core => core_entry%core
else
core => null ()
end if
end function core_entry_get_core_ptr
@ %def core_entry_get_core_ptr
@ Configure the core object after allocation with correct type. The
[[core_def]] object pointer and the index [[i_component]] of the associated
process component are already there.
<<PCM base: core entry: TBP>>=
procedure :: configure => core_entry_configure
<<PCM base: sub interfaces>>=
module subroutine core_entry_configure (core_entry, lib, id)
class(core_entry_t), intent(inout) :: core_entry
type(process_library_t), intent(in), target :: lib
type(string_t), intent(in) :: id
end subroutine core_entry_configure
<<PCM base: procedures>>=
module subroutine core_entry_configure (core_entry, lib, id)
class(core_entry_t), intent(inout) :: core_entry
type(process_library_t), intent(in), target :: lib
type(string_t), intent(in) :: id
call core_entry%core%init &
(core_entry%core_def, lib, id, core_entry%i_component)
end subroutine core_entry_configure
@ %def core_entry_configure
@
\subsection{Process component manager}
The process-component manager [[pcm]] is the master component of the
[[process_t]] object. It serves two purposes:
\begin{enumerate}
\item
It holds configuration data which allow us to centrally manage the
components, terms, etc.\ of the process object.
\item
It implements the methods that realize the algorithm for constructing
the process object and computing an integral. This algorithm makes
use of the data stored within [[pcm]].
\end{enumerate}
To this end, the object is abstract and polymorphic. The two
extensions that we support, implement (a) default tree-level
calculation, optionally including a sum over sub-processes with
different particle content, or (b) the FKS-NLO subtraction algorithm for
QCD-corrected processes. In both cases, the type extensions may hold
suitable further data.
Data included in the base type:
The number of components determines the [[component_selected]] array.
[[i_phs_config]] is a lookup table that holds the PHS configuration index
for a given component index.
[[i_core]] is a lookup table that holds the core-entry index for a
given component index.
[[i_mci]] is a lookup table that holds the integrator (MCI) index for
a given component index.
<<PCM base: public>>=
public :: pcm_t
<<PCM base: types>>=
type, abstract :: pcm_t
logical :: initialized = .false.
logical :: has_pdfs = .false.
integer :: n_components = 0
integer :: n_cores = 0
integer :: n_mci = 0
logical, dimension(:), allocatable :: component_selected
logical, dimension(:), allocatable :: component_active
integer, dimension(:), allocatable :: i_phs_config
integer, dimension(:), allocatable :: i_core
integer, dimension(:), allocatable :: i_mci
type(blha_template_t) :: blha_defaults
logical :: uses_blha = .false.
type(os_data_t) :: os_data
contains
<<PCM base: pcm: TBP>>
end type pcm_t
@ %def pcm_t
@ The factory method. We use the [[inout]] intent, so calling this
again is an error.
<<PCM base: pcm: TBP>>=
procedure(pcm_allocate_workspace), deferred :: allocate_workspace
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_allocate_workspace (pcm, work)
import
class(pcm_t), intent(in) :: pcm
class(pcm_workspace_t), intent(inout), allocatable :: work
end subroutine pcm_allocate_workspace
end interface
@ %def pcm_allocate_workspace
@
<<PCM base: pcm: TBP>>=
procedure(pcm_is_nlo), deferred :: is_nlo
<<PCM base: interfaces>>=
abstract interface
function pcm_is_nlo (pcm) result (is_nlo)
import
logical :: is_nlo
class(pcm_t), intent(in) :: pcm
end function pcm_is_nlo
end interface
@ %def pcm_is_nlo
@
<<PCM base: pcm: TBP>>=
procedure(pcm_final), deferred :: final
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_final (pcm)
import
class(pcm_t), intent(inout) :: pcm
end subroutine pcm_final
end interface
@ %def pcm_final
@
\subsection{Initialization methods}
The PCM has the duty to coordinate and configure the process-object
components.
Initialize the PCM configuration itself, using environment data.
<<PCM base: pcm: TBP>>=
procedure(pcm_init), deferred :: init
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_init (pcm, env, meta)
import
class(pcm_t), intent(out) :: pcm
type(process_environment_t), intent(in) :: env
type(process_metadata_t), intent(in) :: meta
end subroutine pcm_init
end interface
@ %def pcm_init
@
Initialize the BLHA configuration block, the component-independent default
settings. This is to be called by [[pcm_init]]. We use the provided variable
list.
This block is filled regardless of whether BLHA is actually used, because why
not? We use a default value for the scheme (not set in unit tests).
<<PCM base: pcm: TBP>>=
procedure :: set_blha_defaults => pcm_set_blha_defaults
<<PCM base: sub interfaces>>=
module subroutine pcm_set_blha_defaults (pcm, polarized_beams, var_list)
class(pcm_t), intent(inout) :: pcm
type(var_list_t), intent(in) :: var_list
logical, intent(in) :: polarized_beams
end subroutine pcm_set_blha_defaults
<<PCM base: procedures>>=
module subroutine pcm_set_blha_defaults (pcm, polarized_beams, var_list)
class(pcm_t), intent(inout) :: pcm
type(var_list_t), intent(in) :: var_list
logical, intent(in) :: polarized_beams
logical :: muon_yukawa_off
real(default) :: top_yukawa
type(string_t) :: ew_scheme
muon_yukawa_off = &
var_list%get_lval (var_str ("?openloops_switch_off_muon_yukawa"))
top_yukawa = &
var_list%get_rval (var_str ("blha_top_yukawa"))
ew_scheme = &
var_list%get_sval (var_str ("$blha_ew_scheme"))
if (ew_scheme == "") ew_scheme = "Gmu"
call pcm%blha_defaults%init &
(polarized_beams, muon_yukawa_off, top_yukawa, ew_scheme)
end subroutine pcm_set_blha_defaults
@ %def pcm_set_blha_defaults
@ Read the method settings from the variable list and store them in the BLHA
master. The details depend on the [[pcm]] concrete type.
<<PCM base: pcm: TBP>>=
procedure(pcm_set_blha_methods), deferred :: set_blha_methods
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_set_blha_methods (pcm, blha_master, var_list)
import
class(pcm_t), intent(inout) :: pcm
type(blha_master_t), intent(inout) :: blha_master
type(var_list_t), intent(in) :: var_list
end subroutine pcm_set_blha_methods
end interface
@ %def pcm_set_blha_methods
@ Produce the LO and NLO flavor-state tables (as far as available), as
appropriate for BLHA configuration. We may inspect either the PCM itself or
the array of process cores.
<<PCM base: pcm: TBP>>=
procedure(pcm_get_blha_flv_states), deferred :: get_blha_flv_states
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_get_blha_flv_states (pcm, core_entry, flv_born, flv_real)
import
class(pcm_t), intent(in) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
integer, dimension(:,:), allocatable, intent(out) :: flv_born
integer, dimension(:,:), allocatable, intent(out) :: flv_real
end subroutine pcm_get_blha_flv_states
end interface
@ %def pcm_get_blha_flv_states
@
Allocate the right number of process components. The number is also stored in
the process meta. Initially, all components are active but none are
selected.
<<PCM base: pcm: TBP>>=
procedure :: allocate_components => pcm_allocate_components
<<PCM base: sub interfaces>>=
module subroutine pcm_allocate_components (pcm, comp, meta)
class(pcm_t), intent(inout) :: pcm
type(process_component_t), dimension(:), allocatable, intent(out) :: comp
type(process_metadata_t), intent(in) :: meta
end subroutine pcm_allocate_components
<<PCM base: procedures>>=
module subroutine pcm_allocate_components (pcm, comp, meta)
class(pcm_t), intent(inout) :: pcm
type(process_component_t), dimension(:), allocatable, intent(out) :: comp
type(process_metadata_t), intent(in) :: meta
pcm%n_components = meta%n_components
allocate (comp (pcm%n_components))
allocate (pcm%component_selected (pcm%n_components), source = .false.)
allocate (pcm%component_active (pcm%n_components), source = .true.)
end subroutine pcm_allocate_components
@ %def pcm_allocate_components
@ Each process component belongs to a category/type, which we identify by a
universal integer constant. The categories can be taken from the process
definition. For easy lookup, we store the categories in an array.
<<PCM base: pcm: TBP>>=
procedure(pcm_categorize_components), deferred :: categorize_components
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_categorize_components (pcm, config)
import
class(pcm_t), intent(inout) :: pcm
type(process_config_data_t), intent(in) :: config
end subroutine pcm_categorize_components
end interface
@ %def pcm_categorize_components
@
Allocate the right number and type(s) of process-core
objects, i.e., the interface object between the process and matrix-element
code.
Within the [[pcm]] block, also associate cores with components and store
relevant configuration data, including the [[i_core]] lookup table.
<<PCM base: pcm: TBP>>=
procedure(pcm_allocate_cores), deferred :: allocate_cores
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_allocate_cores (pcm, config, core_entry)
import
class(pcm_t), intent(inout) :: pcm
type(process_config_data_t), intent(in) :: config
type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
end subroutine pcm_allocate_cores
end interface
@ %def pcm_allocate_cores
@ Generate and interface external code for a single core, if this is
required.
<<PCM base: pcm: TBP>>=
procedure(pcm_prepare_any_external_code), deferred :: &
prepare_any_external_code
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_prepare_any_external_code &
(pcm, core_entry, i_core, libname, model, var_list)
import
class(pcm_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
integer, intent(in) :: i_core
type(string_t), intent(in) :: libname
type(model_data_t), intent(in), target :: model
type(var_list_t), intent(in) :: var_list
end subroutine pcm_prepare_any_external_code
end interface
@ %def pcm_prepare_any_external_code
@ Prepare the BLHA configuration for a core object that requires it. This
does not affect the core object, which may not yet be allocated.
<<PCM base: pcm: TBP>>=
procedure(pcm_setup_blha), deferred :: setup_blha
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_setup_blha (pcm, core_entry)
import
class(pcm_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
end subroutine pcm_setup_blha
end interface
@ %def pcm_setup_blha
@ Configure the BLHA interface for a core object that requires it. This is
separate from the previous method, assuming that the [[pcm]] has to allocate
the actual cores and acquire some data in-between.
<<PCM base: pcm: TBP>>=
procedure(pcm_prepare_blha_core), deferred :: prepare_blha_core
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_prepare_blha_core (pcm, core_entry, model)
import
class(pcm_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
class(model_data_t), intent(in), target :: model
end subroutine pcm_prepare_blha_core
end interface
@ %def pcm_prepare_blha_core
@ Allocate and configure the MCI (multi-channel integrator) records and their
relation to process components, appropriate for the algorithm implemented by
[[pcm]].
Create a [[mci_t]] template: the procedure [[dispatch_mci]] is called as a
factory method for allocating the [[mci_t]] object with a specific concrete
type. The call may depend on the concrete [[pcm]] type.
<<PCM base: public>>=
public :: dispatch_mci_proc
<<PCM base: interfaces>>=
abstract interface
subroutine dispatch_mci_proc (mci, var_list, process_id, is_nlo)
import
class(mci_t), allocatable, intent(out) :: mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
logical, intent(in), optional :: is_nlo
end subroutine dispatch_mci_proc
end interface
@ %def dispatch_mci_proc
<<PCM base: pcm: TBP>>=
procedure(pcm_setup_mci), deferred :: setup_mci
procedure(pcm_call_dispatch_mci), deferred :: call_dispatch_mci
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_setup_mci (pcm, mci_entry)
import
class(pcm_t), intent(inout) :: pcm
type(process_mci_entry_t), &
dimension(:), allocatable, intent(out) :: mci_entry
end subroutine pcm_setup_mci
end interface
abstract interface
subroutine pcm_call_dispatch_mci (pcm, &
dispatch_mci, var_list, process_id, mci_template)
import
class(pcm_t), intent(inout) :: pcm
procedure(dispatch_mci_proc) :: dispatch_mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
class(mci_t), intent(out), allocatable :: mci_template
end subroutine pcm_call_dispatch_mci
end interface
@ %def pcm_setup_mci
@ %def pcm_call_dispatch_mci
@ Proceed with PCM configuration based on the core and component
configuration data. Base version is empty.
<<PCM base: pcm: TBP>>=
procedure(pcm_complete_setup), deferred :: complete_setup
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_complete_setup (pcm, core_entry, component, model)
import
class(pcm_t), intent(inout) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
type(process_component_t), dimension(:), intent(inout) :: component
type(model_t), intent(in), target :: model
end subroutine pcm_complete_setup
end interface
@ %def pcm_complete_setup
@
\subsubsection{Retrieve information}
Return the core index that belongs to a particular component.
<<PCM base: pcm: TBP>>=
procedure :: get_i_core => pcm_get_i_core
<<PCM base: sub interfaces>>=
module function pcm_get_i_core (pcm, i_component) result (i_core)
class(pcm_t), intent(in) :: pcm
integer, intent(in) :: i_component
integer :: i_core
end function pcm_get_i_core
<<PCM base: procedures>>=
module function pcm_get_i_core (pcm, i_component) result (i_core)
class(pcm_t), intent(in) :: pcm
integer, intent(in) :: i_component
integer :: i_core
if (allocated (pcm%i_core)) then
i_core = pcm%i_core(i_component)
else
i_core = 0
end if
end function pcm_get_i_core
@ %def pcm_get_i_core
@
\subsubsection{Phase-space configuration}
Allocate and initialize the right number and type(s) of phase-space
configuration entries. The [[i_phs_config]] lookup table must be set
accordingly.
<<PCM base: pcm: TBP>>=
procedure(pcm_init_phs_config), deferred :: init_phs_config
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_init_phs_config &
(pcm, phs_entry, meta, env, phs_par, mapping_defs)
import
class(pcm_t), intent(inout) :: pcm
type(process_phs_config_t), &
dimension(:), allocatable, intent(out) :: phs_entry
type(process_metadata_t), intent(in) :: meta
type(process_environment_t), intent(in) :: env
type(mapping_defaults_t), intent(in) :: mapping_defs
type(phs_parameters_t), intent(in) :: phs_par
end subroutine pcm_init_phs_config
end interface
@ %def pcm_init_phs_config
@
Initialize a single component. We require all process-configuration blocks,
and specific templates for the phase-space and integrator configuration.
We also provide the current component index [[i]] and the [[active]] flag.
<<PCM base: pcm: TBP>>=
procedure(pcm_init_component), deferred :: init_component
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_init_component &
(pcm, component, i, active, phs_config, env, meta, config)
import
class(pcm_t), intent(in) :: pcm
type(process_component_t), intent(out) :: component
integer, intent(in) :: i
logical, intent(in) :: active
class(phs_config_t), allocatable, intent(in) :: phs_config
type(process_environment_t), intent(in) :: env
type(process_metadata_t), intent(in) :: meta
type(process_config_data_t), intent(in) :: config
end subroutine pcm_init_component
end interface
@ %def pcm_init_component
@
Record components in the process [[meta]] data if they have turned
out to be inactive.
<<PCM base: pcm: TBP>>=
procedure :: record_inactive_components => pcm_record_inactive_components
<<PCM base: sub interfaces>>=
module subroutine pcm_record_inactive_components (pcm, component, meta)
class(pcm_t), intent(inout) :: pcm
type(process_component_t), dimension(:), intent(in) :: component
type(process_metadata_t), intent(inout) :: meta
end subroutine pcm_record_inactive_components
<<PCM base: procedures>>=
module subroutine pcm_record_inactive_components (pcm, component, meta)
class(pcm_t), intent(inout) :: pcm
type(process_component_t), dimension(:), intent(in) :: component
type(process_metadata_t), intent(inout) :: meta
integer :: i
pcm%component_active = component%active
do i = 1, pcm%n_components
if (.not. component(i)%active) call meta%deactivate_component (i)
end do
end subroutine pcm_record_inactive_components
@ %def pcm_record_inactive_components
@
\subsection{Manager workspace}
This object deals with the actual (squared) matrix element values. It
holds any central data that are generated and/or used when calculating
a particular phase-space point.
Since phase-space points are associated with an integrator, we expect the
instances of this type to correspond to MCI instances.
<<PCM base: public>>=
public :: pcm_workspace_t
<<PCM base: types>>=
type, abstract :: pcm_workspace_t
! class(pcm_t), pointer :: config => null ()
logical :: bad_point = .false.
contains
<<PCM base: pcm instance: TBP>>
end type pcm_workspace_t
@ %def pcm_workspace_t
@
<<PCM base: pcm instance: TBP>>=
procedure(pcm_work_final), deferred :: final
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_work_final (pcm_work)
import
class(pcm_workspace_t), intent(inout) :: pcm_work
end subroutine pcm_work_final
end interface
@ %def pcm_work_final
@
<<PCM base: pcm instance: TBP>>=
procedure(pcm_work_is_nlo), deferred :: is_nlo
<<PCM base: interfaces>>=
abstract interface
function pcm_work_is_nlo (pcm_work) result (is_nlo)
import
logical :: is_nlo
class(pcm_workspace_t), intent(inout) :: pcm_work
end function pcm_work_is_nlo
end interface
@ %def pcm_work_is_nlo
@
<<XXX PCM base: pcm instance: TBP>>=
procedure :: link_config => pcm_work_link_config
<<XXX PCM base: procedures>>=
subroutine pcm_work_link_config (pcm_work, config)
class(pcm_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in), target :: config
pcm_work%config => config
end subroutine pcm_work_link_config
@ %def pcm_work_link_config
@
<<PCM base: pcm instance: TBP>>=
procedure :: is_valid => pcm_work_is_valid
<<PCM base: sub interfaces>>=
module function pcm_work_is_valid (pcm_work) result (valid)
logical :: valid
class(pcm_workspace_t), intent(in) :: pcm_work
end function pcm_work_is_valid
<<PCM base: procedures>>=
module function pcm_work_is_valid (pcm_work) result (valid)
logical :: valid
class(pcm_workspace_t), intent(in) :: pcm_work
valid = .not. pcm_work%bad_point
end function pcm_work_is_valid
@ %def pcm_work_is_valid
@
<<PCM base: pcm instance: TBP>>=
procedure :: set_bad_point => pcm_work_set_bad_point
<<PCM base: sub interfaces>>=
pure module subroutine pcm_work_set_bad_point (pcm_work, bad_point)
class(pcm_workspace_t), intent(inout) :: pcm_work
logical, intent(in) :: bad_point
end subroutine pcm_work_set_bad_point
<<PCM base: procedures>>=
pure module subroutine pcm_work_set_bad_point (pcm_work, bad_point)
class(pcm_workspace_t), intent(inout) :: pcm_work
logical, intent(in) :: bad_point
pcm_work%bad_point = pcm_work%bad_point .or. bad_point
end subroutine pcm_work_set_bad_point
@ %def pcm_work_set_bad_point
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{The process object}
<<[[process.f90]]>>=
<<File header>>
module process
<<Use kinds>>
<<Use strings>>
<<Use debug>>
use diagnostics
use lorentz
use rng_base
use dispatch_rng, only: dispatch_rng_factory
use dispatch_rng, only: update_rng_seed_in_var_list
use os_interface
use sm_qcd
use mci_base
use flavors
use model_data
use models
use process_libraries
use process_constants
use variables
use beam_structures
use beams
use pdg_arrays
use expr_base
use sf_base
use sf_mappings
use resonances, only: resonance_history_t, resonance_history_set_t
use prc_test_core, only: test_t
use prc_core_def, only: prc_core_def_t
use prc_core, only: prc_core_t, helicity_selection_t
use phs_base
use parton_states, only: connected_state_t
use pcm_base
use pcm
use process_counter
use process_config
use process_mci
<<Standard module head>>
<<Process: public>>
<<Process: types>>
<<Process: interfaces>>
interface
<<Process: sub interfaces>>
end interface
contains
<<Process: main procedures>>
end module process
@ %def process
@
<<[[process_sub.f90]]>>=
<<File header>>
submodule (process) process_s
use io_units
use format_utils, only: write_separator
use constants
use numeric_utils
use cputime
use md5
use integration_results
use physics_defs
use interactions
use particles
use dispatch_phase_space, only: dispatch_phs
use prc_external, only: prc_external_t
use prc_recola, only: prc_recola_t
use blha_olp_interfaces, only: prc_blha_t, blha_template_t
use prc_threshold, only: prc_threshold_t
use phs_fks, only: phs_fks_config_t
use mappings, only: mapping_defaults_t
use phs_forests, only: phs_parameters_t
use phs_wood, only: phs_wood_config_t
use blha_config, only: blha_master_t
implicit none
contains
<<Process: procedures>>
end submodule process_s
@ %def process_s
@
\subsection{Process status}
Store counter and status information in a process object.
<<Process: types>>=
type :: process_status_t
private
end type process_status_t
@ %def process_status_t
@
\subsection{Process status}
Store integration results in a process object.
<<Process: types>>=
type :: process_results_t
private
end type process_results_t
@ %def process_results_t
@
\subsection{The process type}
NOTE: The description below represents the intended structure after
refactoring and disentangling the FKS-NLO vs. LO algorithm dependencies.
A [[process]] object is the internal representation of integration-run
methods and data, as they are controlled by the user via a Sindarin
script. The process object provides access to matrix elements (the
actual ``process'' definitions that the user has provided before), it
defines the separation into individually integrable components, and it
manages phase-space construction, the actual integration over phase
space, and the accumulation of results.
As a workspace for individual sampling calls, we introduce an
associated [[process_instance]] object type elsewhere. The
[[process]] object contains data that either define the configuration
or accumulate results from a complete integration pass.
After successful phase-space integration, subsequent event generation
is not actually represented by the [[process]] object. However, any
event generation refers to an existing [[process]] object which
represents a specific integration pass, and it uses a fresh
[[process_instance]] workspace for calculations.
The process object consists of several subobjects with their specific
purposes. The corresponding types are defined below. (Technically,
the subobject type definitions have to come before the process type
definition, but with NOWEB magic we reverse this order here.)
The [[meta]] object describes the process globally. All
contents become fixed when the object is initialized. Similarly, the
[[env]] component captures the (Sindarin) environment at the point
where the process object is initialized.
The [[config]] object holds physical and technical configuration data
that are collected and derived from the environment during process
initialization, and which are common to all process components.
The [[pcm]] object (process-component manager) is polymorphic. This
is an object which holds data which represent the process-object
structure and breakdown, and it contains the methods that implement
the algorithm of managing this structure, accumulating partial
results, and finally collecting the pieces. Depending on the generic
process type, the contents of [[pcm]] do vary. In particular, there
is some base-type data content and a simple (default) extension which
is designed for traditional \oMega\ matrix elements and tree-level
integration, possibly with several sub-processes to sum over. The
second extension is designed for the FKS phase-space and subtraction
algorithm for NLO QCD, which interfaces external one-loop providers.
The [[component]] subobjects are, first of all, interfaces to the
original process-component definitions that have been provided by the
user, which the program has already taken to produce matrix-element
code and interfaces. The management of those components is deferred
by [[pcm]], which contains the information that defines the role of
each component. In particular, in the default (LO) version, process
components correspond to distinct particle combinations which have
been included in the original process definition. In the FKS-NLO
version, the breakdown of a NLO process into Born, real, virtual,
etc.\ components determines the setup.
The [[phs_config]] subobjects hold data that allow and implement the
construction of phase-space configurations. The type
[[process_phs_config_t]] is a wrapper type around the concrete
polymorphic [[phs_config_t]] object type, which manages phase-space
construction, including some bookkeeping required for setting up
multi-channel integration. In the LO case, we expect a separate entry
for each independent sub-process. For the FKS-NLO algorithm, we
expect several entries: a default-type entry which implements the
underlying Born phase space, and additional entries which enable
the construction of various real-radiation and subtraction kinematics
configurations.
A [[core_entry]] is the interface to existing matrix-element and
interaction code. Depending on the process and its components, there
may be various distinct matrix elements to compute.
The [[mci_entry]] objects configure distinct MC input parameter sets
and their associated (multi-channel) integrators.
The [[rng_factory]] object is a single objects which constructs
individual random-number generators for various tasks, in a uniform
and well-defined way.
The [[beam_config]] object describes the incoming particles, either the
decay mother or the scattering beams. It also contains the spectrum-
and structure-function setup, which has to interact with the
phase-space and integrator facilities.
The [[term]] subobjects break down the process in its smallest parts
which appear in the calculation. For LO processes, the correspondence
between terms and components is one-to-one. The FKS-NLO algorithm
requires not just separation of Born, real, and virtual components but
also subtraction terms, and a decomposition of the real phase space
into singular regions. The general idea is that the integration
results of distinct sets of terms are summed over to provide the
results of individual components. This is also controlled by the
[[pcm]] subobject.
The [[process_status]] object is a bookkeeping device that allows us
to query the status of an ongoing calculation.
The [[process_results]] object collects the integration results for
external use, including integration history information.
<<Process: public>>=
public :: process_t
<<Process: types>>=
type :: process_t
private
type(process_metadata_t) :: &
meta
type(process_environment_t) :: &
env
type(process_config_data_t) :: &
config
class(pcm_t), allocatable :: &
pcm
type(process_component_t), dimension(:), allocatable :: &
component
type(process_phs_config_t), dimension(:), allocatable :: &
phs_entry
type(core_entry_t), dimension(:), allocatable :: &
core_entry
type(process_mci_entry_t), dimension(:), allocatable :: &
mci_entry
class(rng_factory_t), allocatable :: &
rng_factory
type(process_beam_config_t) :: &
beam_config
type(process_term_t), dimension(:), allocatable :: &
term
type(process_status_t) :: &
status
type(process_results_t) :: &
result
contains
<<Process: process: TBP>>
end type process_t
@ %def process_t
@
\subsection{Process pointer}
Wrapper type for storing pointers to process objects in arrays.
<<Process: public>>=
public :: process_ptr_t
<<Process: types>>=
type :: process_ptr_t
type(process_t), pointer :: p => null ()
end type process_ptr_t
@ %def process_ptr_t
@
\subsection{Output}
This procedure is an important debugging and inspection tool; it is
not used during normal operation. The process object is written
to a file (identified by unit, which may also be standard output).
Optional flags determine whether we show everything or just the
interesting parts.
The shorthand as a traditional TBP.
<<Process: process: TBP>>=
procedure :: write => process_write
<<Process: sub interfaces>>=
module subroutine process_write (process, screen, unit, &
show_os_data, show_var_list, show_rng, show_expressions, pacify)
class(process_t), intent(in) :: process
logical, intent(in) :: screen
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_os_data
logical, intent(in), optional :: show_var_list
logical, intent(in), optional :: show_rng
logical, intent(in), optional :: show_expressions
logical, intent(in), optional :: pacify
end subroutine process_write
<<Process: procedures>>=
module subroutine process_write (process, screen, unit, &
show_os_data, show_var_list, show_rng, show_expressions, pacify)
class(process_t), intent(in) :: process
logical, intent(in) :: screen
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_os_data
logical, intent(in), optional :: show_var_list
logical, intent(in), optional :: show_rng
logical, intent(in), optional :: show_expressions
logical, intent(in), optional :: pacify
integer :: u, iostat
character(0) :: iomsg
integer, dimension(:), allocatable :: v_list
u = given_output_unit (unit)
allocate (v_list (0))
call set_flag (v_list, F_SHOW_OS_DATA, show_os_data)
call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list)
call set_flag (v_list, F_SHOW_RNG, show_rng)
call set_flag (v_list, F_SHOW_EXPRESSIONS, show_expressions)
call set_flag (v_list, F_PACIFY, pacify)
if (screen) then
call process%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg)
else
call process%write_formatted (u, "DT", v_list, iostat, iomsg)
end if
end subroutine process_write
@ %def process_write
@ Standard DTIO procedure with binding.
For the particular application, the screen format is triggered by the
[[LISTDIRECTED]] option for the [[iotype]] format editor string. The
other options activate when the particular parameter value is found in
[[v_list]].
NOTE: The DTIO [[generic]] binding is supported by gfortran since 7.0.
TODO wk 2018: The default could be to show everything, and we should have separate
switches for all major parts. Currently, there are only a few.
<<Process: process: TBP>>=
! generic :: write (formatted) => write_formatted
procedure :: write_formatted => process_write_formatted
<<Process: sub interfaces>>=
module subroutine process_write_formatted (dtv, unit, iotype, &
v_list, iostat, iomsg)
class(process_t), intent(in) :: dtv
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, dimension(:), intent(in) :: v_list
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
end subroutine process_write_formatted
<<Process: procedures>>=
module subroutine process_write_formatted (dtv, unit, iotype, &
v_list, iostat, iomsg)
class(process_t), intent(in) :: dtv
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, dimension(:), intent(in) :: v_list
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
integer :: u
logical :: screen
logical :: var_list
logical :: rng_factory
logical :: expressions
logical :: counters
logical :: os_data
logical :: model
logical :: pacify
integer :: i
u = unit
select case (iotype)
case ("LISTDIRECTED")
screen = .true.
case default
screen = .false.
end select
var_list = flagged (v_list, F_SHOW_VAR_LIST)
rng_factory = flagged (v_list, F_SHOW_RNG, .true.)
expressions = flagged (v_list, F_SHOW_EXPRESSIONS)
counters = .true.
os_data = flagged (v_list, F_SHOW_OS_DATA)
model = .false.
pacify = flagged (v_list, F_PACIFY)
associate (process => dtv)
if (screen) then
write (msg_buffer, "(A)") repeat ("-", 72)
call msg_message ()
else
call write_separator (u, 2)
end if
call process%meta%write (u, screen)
if (var_list) then
call process%env%write (u, show_var_list=var_list, &
show_model=.false., show_lib=.false., &
show_os_data=os_data)
else if (.not. screen) then
write (u, "(1x,A)") "Variable list: [not shown]"
end if
if (process%meta%type == PRC_UNKNOWN) then
call write_separator (u, 2)
return
else if (screen) then
return
end if
call write_separator (u)
call process%config%write (u, counters, model, expressions)
if (rng_factory) then
if (allocated (process%rng_factory)) then
call write_separator (u)
call process%rng_factory%write (u)
end if
end if
call write_separator (u, 2)
if (allocated (process%component)) then
write (u, "(1x,A)") "Process component configuration:"
do i = 1, size (process%component)
call write_separator (u)
call process%component(i)%write (u)
end do
else
write (u, "(1x,A)") "Process component configuration: [undefined]"
end if
call write_separator (u, 2)
if (allocated (process%term)) then
write (u, "(1x,A)") "Process term configuration:"
do i = 1, size (process%term)
call write_separator (u)
call process%term(i)%write (u)
end do
else
write (u, "(1x,A)") "Process term configuration: [undefined]"
end if
call write_separator (u, 2)
call process%beam_config%write (u)
call write_separator (u, 2)
if (allocated (process%mci_entry)) then
write (u, "(1x,A)") "Multi-channel integrator configurations:"
do i = 1, size (process%mci_entry)
call write_separator (u)
write (u, "(1x,A,I0,A)") "MCI #", i, ":"
call process%mci_entry(i)%write (u, pacify)
end do
end if
call write_separator (u, 2)
end associate
iostat = 0
iomsg = ""
end subroutine process_write_formatted
@ %def process_write_formatted
@
<<Process: process: TBP>>=
procedure :: write_meta => process_write_meta
<<Process: sub interfaces>>=
module subroutine process_write_meta (process, unit, testflag)
class(process_t), intent(in) :: process
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
end subroutine process_write_meta
<<Process: procedures>>=
module subroutine process_write_meta (process, unit, testflag)
class(process_t), intent(in) :: process
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
integer :: u, i
u = given_output_unit (unit)
select case (process%meta%type)
case (PRC_UNKNOWN)
write (u, "(1x,A)") "Process instance [undefined]"
return
case (PRC_DECAY)
write (u, "(1x,A)", advance="no") "Process instance [decay]:"
case (PRC_SCATTERING)
write (u, "(1x,A)", advance="no") "Process instance [scattering]:"
case default
call msg_bug ("process_instance_write: undefined process type")
end select
write (u, "(1x,A,A,A)") "'", char (process%meta%id), "'"
write (u, "(3x,A,A,A)") "Run ID = '", char (process%meta%run_id), "'"
if (allocated (process%meta%component_id)) then
write (u, "(3x,A)") "Process components:"
do i = 1, size (process%meta%component_id)
if (process%pcm%component_selected(i)) then
write (u, "(3x,'*')", advance="no")
else
write (u, "(4x)", advance="no")
end if
write (u, "(1x,I0,9A)") i, ": '", &
char (process%meta%component_id (i)), "': ", &
char (process%meta%component_description (i))
end do
end if
end subroutine process_write_meta
@ %def process_write_meta
@ Screen output. Write a short account of the process configuration
and the current results. The verbose version lists the components,
the short version just the results.
<<Process: process: TBP>>=
procedure :: show => process_show
<<Process: sub interfaces>>=
module subroutine process_show (object, unit, verbose)
class(process_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
end subroutine process_show
<<Process: procedures>>=
module subroutine process_show (object, unit, verbose)
class(process_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer :: u
logical :: verb
real(default) :: err_percent
u = given_output_unit (unit)
verb = .true.; if (present (verbose)) verb = verbose
if (verb) then
call object%meta%show (u, object%config%model%get_name ())
select case (object%meta%type)
case (PRC_DECAY)
write (u, "(2x,A)", advance="no") "Computed width ="
case (PRC_SCATTERING)
write (u, "(2x,A)", advance="no") "Computed cross section ="
case default; return
end select
else
if (object%meta%run_id /= "") then
write (u, "('Run',1x,A,':',1x)", advance="no") &
char (object%meta%run_id)
end if
write (u, "(A)", advance="no") char (object%meta%id)
select case (object%meta%num_id)
case (0)
write (u, "(':')")
case default
write (u, "(1x,'(',I0,')',':')") object%meta%num_id
end select
write (u, "(2x)", advance="no")
end if
if (object%has_integral_tot ()) then
write (u, "(ES14.7,1x,'+-',ES9.2)", advance="no") &
object%get_integral_tot (), object%get_error_tot ()
select case (object%meta%type)
case (PRC_DECAY)
write (u, "(1x,A)", advance="no") "GeV"
case (PRC_SCATTERING)
write (u, "(1x,A)", advance="no") "fb "
case default
write (u, "(1x,A)", advance="no") " "
end select
if (object%get_integral_tot () /= 0) then
err_percent = abs (100 &
* object%get_error_tot () / object%get_integral_tot ())
else
err_percent = 0
end if
if (err_percent == 0) then
write (u, "(1x,'(',F4.0,4x,'%)')") err_percent
else if (err_percent < 0.1) then
write (u, "(1x,'(',F7.3,1x,'%)')") err_percent
else if (err_percent < 1) then
write (u, "(1x,'(',F6.2,2x,'%)')") err_percent
else if (err_percent < 10) then
write (u, "(1x,'(',F5.1,3x,'%)')") err_percent
else
write (u, "(1x,'(',F4.0,4x,'%)')") err_percent
end if
else
write (u, "(A)") "[integral undefined]"
end if
end subroutine process_show
@ %def process_show
@ Finalizer. Explicitly iterate over all subobjects that may contain
allocated pointers.
TODO wk 2018 (workaround): The finalizer for the [[config_data]] component is not
called. The reason is that this deletes model data local to the process,
but these could be referenced by pointers (flavor objects) from some
persistent event record. Obviously, such side effects should be avoided, but
this requires refactoring the event-handling procedures.
<<Process: process: TBP>>=
procedure :: final => process_final
<<Process: sub interfaces>>=
module subroutine process_final (process)
class(process_t), intent(inout) :: process
end subroutine process_final
<<Process: procedures>>=
module subroutine process_final (process)
class(process_t), intent(inout) :: process
integer :: i
call process%env%final ()
if (allocated (process%component)) then
do i = 1, size (process%component)
call process%component(i)%final ()
end do
end if
if (allocated (process%term)) then
do i = 1, size (process%term)
call process%term(i)%final ()
end do
end if
call process%beam_config%final ()
if (allocated (process%mci_entry)) then
do i = 1, size (process%mci_entry)
call process%mci_entry(i)%final ()
end do
end if
if (allocated (process%pcm)) then
call process%pcm%final ()
deallocate (process%pcm)
end if
end subroutine process_final
@ %def process_final
@
\subsubsection{Process setup}
Initialize a process. We need a process library [[lib]] and the process
identifier [[proc_id]] (string). We will fetch the current run ID from the
variable list [[var_list]].
We collect all important data from the environment and store them in the
appropriate places. OS data, model, and variable list are copied
into [[env]] (true snapshot), also the process library (pointer only).
The [[meta]] subobject is initialized with process ID and attributes taken
from the process library.
We initialize the [[config]] subobject with all data that are relevant for
this run, using the settings from [[env]]. These data determine the MD5 sum
for this run, which allows us to identify the setup and possibly skips in a
later re-run.
We also allocate and initialize the embedded RNG factory. We take the seed
from the [[var_list]], and we should return the [[var_list]] to the caller
with a new seed.
Finally, we allocate the process component manager [[pcm]], which implements
the chosen algorithm for process integration. The first task of the manager
is to allocate the component array and to determine the component categories
(e.g., Born/Virtual etc.).
TODO wk 2018: The [[pcm]] dispatcher should be provided by the caller, if we
eventually want to eliminate dependencies on concrete [[pcm_t]] extensions.
Gfortran 7/8/9 bug, has to remain in the main module:
<<Process: process: TBP>>=
procedure :: init => process_init
<<Process: main procedures>>=
subroutine process_init &
(process, proc_id, lib, os_data, model, var_list, beam_structure)
class(process_t), intent(out) :: process
type(string_t), intent(in) :: proc_id
type(process_library_t), intent(in), target :: lib
type(os_data_t), intent(in) :: os_data
class(model_t), intent(in), target :: model
type(var_list_t), intent(inout), target, optional :: var_list
type(beam_structure_t), intent(in), optional :: beam_structure
integer :: next_rng_seed
if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_init")
associate &
(meta => process%meta, env => process%env, config => process%config)
call env%init &
(model, lib, os_data, var_list, beam_structure)
call meta%init &
(proc_id, lib, env%get_var_list_ptr ())
call config%init &
(meta, env)
call dispatch_rng_factory &
(process%rng_factory, env%get_var_list_ptr (), next_rng_seed)
call update_rng_seed_in_var_list (var_list, next_rng_seed)
call dispatch_pcm &
(process%pcm, config%process_def%is_nlo ())
associate (pcm => process%pcm)
call pcm%init (env, meta)
call pcm%allocate_components (process%component, meta)
call pcm%categorize_components (config)
end associate
end associate
end subroutine process_init
@ %def process_init
@
\subsection{Process component manager}
The [[pcm]] (read: process-component manager) takes the responsibility of
steering the actual algorithm of configuration and integration. Depending on
the concrete type, different algorithms can be implemented.
The first version of this supports just two implementations: leading-order
(tree-level) integration and event generation, and NLO (QCD/FKS subtraction).
We thus can start with a single logical for steering the dispatcher.
TODO wk 2018: Eventually, we may eliminate all references to the extensions of
[[pcm_t]] from this module and therefore move this outside the module as well.
Gfortran 7/8/9 bug, has to be in the main module:
<<Process: main procedures>>=
subroutine dispatch_pcm (pcm, is_nlo)
class(pcm_t), allocatable, intent(out) :: pcm
logical, intent(in) :: is_nlo
if (.not. is_nlo) then
allocate (pcm_default_t :: pcm)
else
allocate (pcm_nlo_t :: pcm)
end if
end subroutine dispatch_pcm
@ %def dispatch_pcm
@ This step is performed after phase-space and core objects are done: collect
all missing information and prepare the process component manager for the
appropriate integration algorithm.
<<Process: process: TBP>>=
procedure :: complete_pcm_setup => process_complete_pcm_setup
<<Process: sub interfaces>>=
module subroutine process_complete_pcm_setup (process)
class(process_t), intent(inout) :: process
end subroutine process_complete_pcm_setup
<<Process: procedures>>=
module subroutine process_complete_pcm_setup (process)
class(process_t), intent(inout) :: process
call process%pcm%complete_setup &
(process%core_entry, process%component, process%env%get_model_ptr ())
end subroutine process_complete_pcm_setup
@ %def process_complete_pcm_setup
@
\subsection{Core management}
Allocate cores (interface objects to matrix-element code).
The [[dispatch_core]] procedure is taken as an argument, so we do not depend on
the implementation, and thus on the specific core types.
The [[helicity_selection]] object collects data that the matrix-element
code needs for configuring the appropriate behavior.
After the cores have been allocated, and assuming the phs initial
configuration has been done before, we proceed with computing the [[pcm]]
internal data.
<<Process: process: TBP>>=
procedure :: setup_cores => process_setup_cores
<<Process: sub interfaces>>=
module subroutine process_setup_cores (process, dispatch_core, &
helicity_selection, use_color_factors, has_beam_pol)
class(process_t), intent(inout) :: process
procedure(dispatch_core_proc) :: dispatch_core
type(helicity_selection_t), intent(in), optional :: helicity_selection
logical, intent(in), optional :: use_color_factors
logical, intent(in), optional :: has_beam_pol
end subroutine process_setup_cores
<<Process: procedures>>=
module subroutine process_setup_cores (process, dispatch_core, &
helicity_selection, use_color_factors, has_beam_pol)
class(process_t), intent(inout) :: process
procedure(dispatch_core_proc) :: dispatch_core
type(helicity_selection_t), intent(in), optional :: helicity_selection
logical, intent(in), optional :: use_color_factors
logical, intent(in), optional :: has_beam_pol
integer :: i
associate (pcm => process%pcm)
call pcm%allocate_cores (process%config, process%core_entry)
do i = 1, size (process%core_entry)
call dispatch_core (process%core_entry(i)%core, &
process%core_entry(i)%core_def, &
process%config%model, &
helicity_selection, &
process%config%qcd, &
use_color_factors, &
has_beam_pol)
call process%core_entry(i)%configure &
(process%env%get_lib_ptr (), process%meta%id)
if (process%core_entry(i)%core%uses_blha ()) then
call pcm%setup_blha (process%core_entry(i))
end if
end do
end associate
end subroutine process_setup_cores
@ %def process_setup_cores
<<Process: interfaces>>=
abstract interface
subroutine dispatch_core_proc (core, core_def, model, &
helicity_selection, qcd, use_color_factors, has_beam_pol)
import
class(prc_core_t), allocatable, intent(inout) :: core
class(prc_core_def_t), intent(in) :: core_def
class(model_data_t), intent(in), target, optional :: model
type(helicity_selection_t), intent(in), optional :: helicity_selection
type(qcd_t), intent(in), optional :: qcd
logical, intent(in), optional :: use_color_factors
logical, intent(in), optional :: has_beam_pol
end subroutine dispatch_core_proc
end interface
@ %def dispatch_core_proc
@ Use the [[pcm]] to initialize the BLHA interface for each core which
requires it.
<<Process: process: TBP>>=
procedure :: prepare_blha_cores => process_prepare_blha_cores
<<Process: sub interfaces>>=
module subroutine process_prepare_blha_cores (process)
class(process_t), intent(inout), target :: process
end subroutine process_prepare_blha_cores
<<Process: procedures>>=
module subroutine process_prepare_blha_cores (process)
class(process_t), intent(inout), target :: process
integer :: i
associate (pcm => process%pcm)
do i = 1, size (process%core_entry)
associate (core_entry => process%core_entry(i))
if (core_entry%core%uses_blha ()) then
pcm%uses_blha = .true.
call pcm%prepare_blha_core (core_entry, process%config%model)
end if
end associate
end do
end associate
end subroutine process_prepare_blha_cores
@ %def process_prepare_blha_cores
@ Create the BLHA interface data, using PCM for specific data, and write the
BLHA contract file(s).
We take various configuration data and copy them to the [[blha_master]]
record, which then creates and writes the contracts.
For assigning the QCD/EW coupling powers, we inspect the first process
component only. The other parameters are taken as-is from the process
environment variables.
<<Process: process: TBP>>=
procedure :: create_blha_interface => process_create_blha_interface
<<Process: sub interfaces>>=
module subroutine process_create_blha_interface (process)
class(process_t), intent(inout) :: process
end subroutine process_create_blha_interface
<<Process: procedures>>=
module subroutine process_create_blha_interface (process)
class(process_t), intent(inout) :: process
integer :: alpha_power, alphas_power
integer :: openloops_phs_tolerance, openloops_stability_log
logical :: use_cms
type(string_t) :: ew_scheme, correction_type
type(string_t) :: openloops_extra_cmd, openloops_allowed_libs
type(blha_master_t) :: blha_master
integer, dimension(:,:), allocatable :: flv_born, flv_real
if (process%pcm%uses_blha) then
call collect_configuration_parameters (process%get_var_list_ptr ())
call process%component(1)%config%get_coupling_powers &
(alpha_power, alphas_power)
associate (pcm => process%pcm)
call pcm%set_blha_methods (blha_master, process%get_var_list_ptr ())
call blha_master%set_ew_scheme (ew_scheme)
call blha_master%allocate_config_files ()
call blha_master%set_correction_type (correction_type)
call blha_master%setup_additional_features ( &
openloops_phs_tolerance, &
use_cms, &
openloops_stability_log, &
extra_cmd = openloops_extra_cmd, &
allowed_libs = openloops_allowed_libs, &
beam_structure = process%env%get_beam_structure ())
call pcm%get_blha_flv_states (process%core_entry, flv_born, flv_real)
call blha_master%set_photon_characteristics (flv_born, process%config%n_in)
call blha_master%generate (process%meta%id, &
process%config%model, process%config%n_in, &
alpha_power, alphas_power, &
flv_born, flv_real)
call blha_master%write_olp (process%meta%id)
end associate
end if
contains
subroutine collect_configuration_parameters (var_list)
type(var_list_t), intent(in) :: var_list
openloops_phs_tolerance = &
var_list%get_ival (var_str ("openloops_phs_tolerance"))
openloops_stability_log = &
var_list%get_ival (var_str ("openloops_stability_log"))
use_cms = &
var_list%get_lval (var_str ("?openloops_use_cms"))
ew_scheme = &
var_list%get_sval (var_str ("$blha_ew_scheme"))
correction_type = &
var_list%get_sval (var_str ("$nlo_correction_type"))
openloops_extra_cmd = &
var_list%get_sval (var_str ("$openloops_extra_cmd"))
openloops_allowed_libs = &
var_list%get_sval (var_str ("$openloops_allowed_libs"))
end subroutine collect_configuration_parameters
end subroutine process_create_blha_interface
@ %def process_create_blha_interface
@ Initialize the process components, one by one. We require templates for the
[[mci]] (integrator) and [[phs_config]] (phase-space) configuration data.
The [[active]] flag is set if the component has an associated matrix
element, so we can compute it. The case of no core is a unit-test case.
The specifics depend on the algorithm and are delegated to the [[pcm]]
process-component manager.
The optional [[phs_config]] overrides a pre-generated config array (for unit
test).
<<Process: process: TBP>>=
procedure :: init_components => process_init_components
<<Process: sub interfaces>>=
module subroutine process_init_components (process, phs_config)
class(process_t), intent(inout), target :: process
class(phs_config_t), allocatable, intent(in), optional :: phs_config
end subroutine process_init_components
<<Process: procedures>>=
module subroutine process_init_components (process, phs_config)
class(process_t), intent(inout), target :: process
class(phs_config_t), allocatable, intent(in), optional :: phs_config
integer :: i, i_core
class(prc_core_t), pointer :: core
logical :: active
associate (pcm => process%pcm)
do i = 1, pcm%n_components
i_core = pcm%get_i_core(i)
if (i_core > 0) then
core => process%get_core_ptr (i_core)
active = core%has_matrix_element ()
else
active = .true.
end if
select type (pcm => process%pcm)
type is (pcm_nlo_t)
if (pcm%use_real_partition .and. .not. pcm%use_real_singular) then
if (pcm%component_type(i) == COMP_REAL_SING) then
active = .false.
end if
end if
end select
if (present (phs_config)) then
call pcm%init_component (process%component(i), &
i, &
active, &
phs_config, &
process%env, process%meta, process%config)
else
call pcm%init_component (process%component(i), &
i, &
active, &
process%phs_entry(pcm%i_phs_config(i))%phs_config, &
process%env, process%meta, process%config)
end if
end do
end associate
end subroutine process_init_components
@ %def process_init_components
@ If process components have turned out to be inactive, this has to be
recorded in the [[meta]] block. Delegate to the [[pcm]].
<<Process: process: TBP>>=
procedure :: record_inactive_components => process_record_inactive_components
<<Process: sub interfaces>>=
module subroutine process_record_inactive_components (process)
class(process_t), intent(inout) :: process
end subroutine process_record_inactive_components
<<Process: procedures>>=
module subroutine process_record_inactive_components (process)
class(process_t), intent(inout) :: process
associate (pcm => process%pcm)
call pcm%record_inactive_components (process%component, process%meta)
end associate
end subroutine process_record_inactive_components
@ %def process_record_inactive_components
@ Determine the process terms for each process component.
<<Process: process: TBP>>=
procedure :: setup_terms => process_setup_terms
<<Process: sub interfaces>>=
module subroutine process_setup_terms (process, with_beams)
class(process_t), intent(inout), target :: process
logical, intent(in), optional :: with_beams
end subroutine process_setup_terms
<<Process: procedures>>=
module subroutine process_setup_terms (process, with_beams)
class(process_t), intent(inout), target :: process
logical, intent(in), optional :: with_beams
class(model_data_t), pointer :: model
integer :: i, j, k, i_term
integer, dimension(:), allocatable :: n_entry
integer :: n_components, n_tot
integer :: i_sub
type(string_t) :: subtraction_method
class(prc_core_t), pointer :: core => null ()
logical :: setup_subtraction_component, singular_real
logical :: requires_spin_correlations
integer :: nlo_type_to_fetch, n_emitters
i_sub = 0
model => process%config%model
n_components = process%meta%n_components
allocate (n_entry (n_components), source = 0)
do i = 1, n_components
associate (component => process%component(i))
if (component%active) then
n_entry(i) = 1
if (component%get_nlo_type () == NLO_REAL) then
select type (pcm => process%pcm)
type is (pcm_nlo_t)
if (pcm%component_type(i) /= COMP_REAL_FIN) &
n_entry(i) = n_entry(i) + pcm%region_data%get_n_phs ()
end select
end if
end if
end associate
end do
n_tot = sum (n_entry)
allocate (process%term (n_tot))
k = 0
if (process%is_nlo_calculation ()) then
i_sub = process%component(1)%config%get_associated_subtraction ()
subtraction_method = process%component(i_sub)%config%get_me_method ()
if (debug_on) call msg_debug2 &
(D_PROCESS_INTEGRATION, "process_setup_terms: ", subtraction_method)
end if
do i = 1, n_components
associate (component => process%component(i))
if (.not. component%active) cycle
allocate (component%i_term (n_entry(i)))
do j = 1, n_entry(i)
select type (pcm => process%pcm)
type is (pcm_nlo_t)
singular_real = component%get_nlo_type () == NLO_REAL &
.and. pcm%component_type(i) /= COMP_REAL_FIN
class default
singular_real = .false.
end select
setup_subtraction_component = singular_real .and. j == n_entry(i)
i_term = k + j
component%i_term(j) = i_term
if (singular_real) then
process%term(i_term)%i_sub = k + n_entry(i)
else
process%term(i_term)%i_sub = 0
end if
if (setup_subtraction_component) then
select type (pcm => process%pcm)
class is (pcm_nlo_t)
process%term(i_term)%i_core = pcm%i_core(pcm%i_sub)
end select
else
process%term(i_term)%i_core = process%pcm%get_i_core(i)
end if
if (process%term(i_term)%i_core == 0) then
call msg_bug ("Process '" // char (process%get_id ()) &
// "': core not found!")
end if
core => process%get_core_term (i_term)
if (i_sub > 0) then
select type (pcm => process%pcm)
type is (pcm_nlo_t)
requires_spin_correlations = &
pcm%region_data%requires_spin_correlations ()
n_emitters = pcm%region_data%get_n_emitters_sc ()
class default
requires_spin_correlations = .false.
n_emitters = 0
end select
if (requires_spin_correlations) then
call process%term(i_term)%init ( &
i_term, i, j, core, model, &
nlo_type = component%config%get_nlo_type (), &
use_beam_pol = with_beams, &
subtraction_method = subtraction_method, &
has_pdfs = process%pcm%has_pdfs, &
n_emitters = n_emitters)
else
call process%term(i_term)%init ( &
i_term, i, j, core, model, &
nlo_type = component%config%get_nlo_type (), &
use_beam_pol = with_beams, &
subtraction_method = subtraction_method, &
has_pdfs = process%pcm%has_pdfs)
end if
else
call process%term(i_term)%init ( &
i_term, i, j, core, model, &
nlo_type = component%config%get_nlo_type (), &
use_beam_pol = with_beams, &
has_pdfs = process%pcm%has_pdfs)
end if
end do
end associate
k = k + n_entry(i)
end do
process%config%n_terms = n_tot
end subroutine process_setup_terms
@ %def process_setup_terms
@ Initialize the beam setup. This is the trivial version where the
incoming state of the matrix element coincides with the initial state
of the process. For a scattering process, we need the c.m. energy,
all other variables are set to their default values (no polarization,
lab frame and c.m.\ frame coincide, etc.)
We assume that all components consistently describe a scattering
process, i.e., two incoming particles.
Note: The current layout of the [[beam_data_t]] record requires that the
flavor for each beam is unique. For processes with multiple
flavors in the initial state, one has to set up beams explicitly.
This restriction could be removed by extending the code in the
[[beams]] module.
<<Process: process: TBP>>=
procedure :: setup_beams_sqrts => process_setup_beams_sqrts
<<Process: sub interfaces>>=
module subroutine process_setup_beams_sqrts &
(process, sqrts, beam_structure, i_core)
class(process_t), intent(inout) :: process
real(default), intent(in) :: sqrts
type(beam_structure_t), intent(in), optional :: beam_structure
integer, intent(in), optional :: i_core
end subroutine process_setup_beams_sqrts
<<Process: procedures>>=
module subroutine process_setup_beams_sqrts &
(process, sqrts, beam_structure, i_core)
class(process_t), intent(inout) :: process
real(default), intent(in) :: sqrts
type(beam_structure_t), intent(in), optional :: beam_structure
integer, intent(in), optional :: i_core
type(pdg_array_t), dimension(:,:), allocatable :: pdg_in
integer, dimension(2) :: pdg_scattering
type(flavor_t), dimension(2) :: flv_in
integer :: i, i0, ic
allocate (pdg_in (2, process%meta%n_components))
i0 = 0
do i = 1, process%meta%n_components
if (process%component(i)%active) then
if (present (i_core)) then
ic = i_core
else
ic = process%pcm%get_i_core (i)
end if
associate (core => process%core_entry(ic)%core)
pdg_in(:,i) = core%data%get_pdg_in ()
end associate
if (i0 == 0) i0 = i
end if
end do
do i = 1, process%meta%n_components
if (.not. process%component(i)%active) then
pdg_in(:,i) = pdg_in(:,i0)
end if
end do
if (all (pdg_in%get_length () == 1) .and. &
all (pdg_in(1,:) == pdg_in(1,i0)) .and. &
all (pdg_in(2,:) == pdg_in(2,i0))) then
pdg_scattering(:) = pdg_in(:,i0)%get (1)
call flv_in%init (pdg_scattering, process%config%model)
call process%beam_config%init_scattering (flv_in, sqrts, beam_structure)
else
call msg_fatal ("Setting up process '" // char (process%meta%id) // "':", &
[var_str (" --------------------------------------------"), &
var_str ("Inconsistent initial state. This happens if either "), &
var_str ("several processes with non-matching initial states "), &
var_str ("have been added, or for a single process with an "), &
var_str ("initial state flavor sum. In that case, please set beams "), &
var_str ("explicitly [singling out a flavor / structure function.]")])
end if
end subroutine process_setup_beams_sqrts
@ %def process_setup_beams_sqrts
@ This is the version that applies to decay processes. The energy is the
particle mass, hence no extra argument.
<<Process: process: TBP>>=
procedure :: setup_beams_decay => process_setup_beams_decay
<<Process: sub interfaces>>=
module subroutine process_setup_beams_decay &
(process, rest_frame, beam_structure, i_core)
class(process_t), intent(inout), target :: process
logical, intent(in), optional :: rest_frame
type(beam_structure_t), intent(in), optional :: beam_structure
integer, intent(in), optional :: i_core
end subroutine process_setup_beams_decay
<<Process: procedures>>=
module subroutine process_setup_beams_decay &
(process, rest_frame, beam_structure, i_core)
class(process_t), intent(inout), target :: process
logical, intent(in), optional :: rest_frame
type(beam_structure_t), intent(in), optional :: beam_structure
integer, intent(in), optional :: i_core
type(pdg_array_t), dimension(:,:), allocatable :: pdg_in
integer, dimension(1) :: pdg_decay
type(flavor_t), dimension(1) :: flv_in
integer :: i, i0, ic
allocate (pdg_in (1, process%meta%n_components))
i0 = 0
do i = 1, process%meta%n_components
if (process%component(i)%active) then
if (present (i_core)) then
ic = i_core
else
ic = process%pcm%get_i_core (i)
end if
associate (core => process%core_entry(ic)%core)
pdg_in(:,i) = core%data%get_pdg_in ()
end associate
if (i0 == 0) i0 = i
end if
end do
do i = 1, process%meta%n_components
if (.not. process%component(i)%active) then
pdg_in(:,i) = pdg_in(:,i0)
end if
end do
if (all (pdg_in%get_length () == 1) &
.and. all (pdg_in(1,:) == pdg_in(1,i0))) then
pdg_decay(:) = pdg_in(:,i0)%get (1)
call flv_in%init (pdg_decay, process%config%model)
call process%beam_config%init_decay (flv_in, rest_frame, beam_structure)
else
call msg_fatal ("Setting up decay '" &
// char (process%meta%id) // "': decaying particle not unique")
end if
end subroutine process_setup_beams_decay
@ %def process_setup_beams_decay
@ We have to make sure that the masses of the various flavors
in a given position in the particle string coincide.
<<Process: process: TBP>>=
procedure :: check_masses => process_check_masses
<<Process: sub interfaces>>=
module subroutine process_check_masses (process)
class(process_t), intent(in) :: process
end subroutine process_check_masses
<<Process: procedures>>=
module subroutine process_check_masses (process)
class(process_t), intent(in) :: process
type(flavor_t), dimension(:), allocatable :: flv
real(default), dimension(:), allocatable :: mass
integer :: i, j
integer :: i_component
class(prc_core_t), pointer :: core
do i = 1, process%get_n_terms ()
i_component = process%term(i)%i_component
if (.not. process%component(i_component)%active) cycle
core => process%get_core_term (i)
associate (data => core%data)
allocate (flv (data%n_flv), mass (data%n_flv))
do j = 1, data%n_in + data%n_out
call flv%init (data%flv_state(j,:), process%config%model)
mass = flv%get_mass ()
if (any (.not. nearly_equal(mass, mass(1)))) then
call msg_fatal ("Process '" // char (process%meta%id) // "': " &
// "mass values in flavor combination do not coincide. ")
end if
end do
deallocate (flv, mass)
end associate
end do
end subroutine process_check_masses
@ %def process_check_masses
@ Set up index mapping for [[region_data]] for singular regions
equivalent w.r.t. their amplitudes. Has to be called after
[[region_data]] AND the [[core]] are fully set up. For processes with
structure function, subprocesses which lead to the same amplitude for
the hard interaction can differ if structure functions are applied. In
this case we remap flavor structures to themselves if the eqvivalent
hard interaction flavor structure has no identical initial state.
<<Process: process: TBP>>=
procedure :: optimize_nlo_singular_regions => &
process_optimize_nlo_singular_regions
<<Process: sub interfaces>>=
module subroutine process_optimize_nlo_singular_regions (process)
class(process_t), intent(inout) :: process
end subroutine process_optimize_nlo_singular_regions
<<Process: procedures>>=
module subroutine process_optimize_nlo_singular_regions (process)
class(process_t), intent(inout) :: process
class(prc_core_t), pointer :: core, core_sub
integer, dimension(:), allocatable :: eqv_flv_index_born
integer, dimension(:), allocatable :: eqv_flv_index_real
integer, dimension(:,:), allocatable :: flv_born, flv_real
integer :: i_flv, i_flv2, n_in, i
integer :: i_component, i_core, i_core_sub
logical :: fetched_born, fetched_real
logical :: optimize
fetched_born = .false.; fetched_real = .false.
select type (pcm => process%pcm)
type is (pcm_nlo_t)
optimize = pcm%settings%reuse_amplitudes_fks
if (optimize) then
do i_component = 1, pcm%n_components
i_core = pcm%get_i_core(i_component)
core => process%get_core_ptr (i_core)
if (.not. core%data_known) cycle
associate (data => core%data)
if (pcm%nlo_type_core(i_core) == NLO_REAL .and. &
.not. pcm%component_type(i_component) == COMP_SUB) then
if (allocated (core%data%eqv_flv_index)) then
eqv_flv_index_real = core%get_equivalent_flv_index ()
fetched_real = .true.
end if
i_core_sub = pcm%get_i_core (pcm%i_sub)
core_sub => process%get_core_ptr (i_core_sub)
if (allocated (core_sub%data%eqv_flv_index)) then
eqv_flv_index_born = core_sub%get_equivalent_flv_index ()
fetched_born = .true.
end if
if (fetched_born .and. fetched_real) exit
end if
end associate
end do
if (.not. fetched_born .or. .not. fetched_real) then
call msg_warning('Failed to fetch flavor equivalence indices. &
&Disabling singular region optimization')
optimize = .false.
eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)]
eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)]
end if
if (optimize .and. pcm%has_pdfs) then
flv_born = pcm%region_data%get_flv_states_born ()
flv_real = pcm%region_data%get_flv_states_real ()
n_in = pcm%region_data%n_in
do i_flv = 1, size (eqv_flv_index_born)
do i_flv2 = 1, i_flv
if (any (flv_born(1:n_in, eqv_flv_index_born(i_flv)) /= &
flv_born(1:n_in, i_flv))) then
eqv_flv_index_born(i_flv) = i_flv
exit
end if
end do
end do
do i_flv = 1, size (eqv_flv_index_real)
do i_flv2 = 1, i_flv
if (any (flv_real(1:n_in, eqv_flv_index_real(i_flv)) /= &
flv_real(1:n_in, i_flv))) then
eqv_flv_index_real(i_flv) = i_flv
exit
end if
end do
end do
end if
else
eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)]
eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)]
end if
pcm%region_data%eqv_flv_index_born = eqv_flv_index_born
pcm%region_data%eqv_flv_index_real = eqv_flv_index_real
call pcm%region_data%find_eqv_regions (optimize)
end select
end subroutine process_optimize_nlo_singular_regions
@ %def process_optimize_nlo_singular_regions
@ For some structure functions we need to get the list of initial
state flavors. This is a two-dimensional array. The first index is
the beam index, the second index is the component index. Each array
element is itself a PDG array object, which consists of the list of
incoming PDG values for this beam and component.
<<Process: process: TBP>>=
procedure :: get_pdg_in => process_get_pdg_in
<<Process: sub interfaces>>=
module subroutine process_get_pdg_in (process, pdg_in)
class(process_t), intent(in), target :: process
type(pdg_array_t), dimension(:,:), allocatable, intent(out) :: pdg_in
end subroutine process_get_pdg_in
<<Process: procedures>>=
module subroutine process_get_pdg_in (process, pdg_in)
class(process_t), intent(in), target :: process
type(pdg_array_t), dimension(:,:), allocatable, intent(out) :: pdg_in
integer :: i, i_core
allocate (pdg_in (process%config%n_in, process%meta%n_components))
do i = 1, process%meta%n_components
if (process%component(i)%active) then
i_core = process%pcm%get_i_core (i)
associate (core => process%core_entry(i_core)%core)
pdg_in(:,i) = core%data%get_pdg_in ()
end associate
end if
end do
end subroutine process_get_pdg_in
@ %def process_get_pdg_in
@ The phase-space configuration object, in case we need it separately.
<<Process: process: TBP>>=
procedure :: get_phs_config => process_get_phs_config
<<Process: sub interfaces>>=
module function process_get_phs_config &
(process, i_component) result (phs_config)
class(phs_config_t), pointer :: phs_config
class(process_t), intent(in), target :: process
integer, intent(in) :: i_component
end function process_get_phs_config
<<Process: procedures>>=
module function process_get_phs_config &
(process, i_component) result (phs_config)
class(phs_config_t), pointer :: phs_config
class(process_t), intent(in), target :: process
integer, intent(in) :: i_component
if (allocated (process%component)) then
if (process%component(i_component)%active) then
phs_config => process%component(i_component)%phs_config
else
phs_config => null ()
end if
else
phs_config => null ()
end if
end function process_get_phs_config
@ %def process_get_phs_config
@ The resonance history set can be extracted from the phase-space
configuration. However, this is only possible if the default phase-space
method (wood) has been chosen. If [[include_trivial]] is set, we include the
resonance history with no resonances in the set.
<<Process: process: TBP>>=
procedure :: extract_resonance_history_set &
=> process_extract_resonance_history_set
<<Process: sub interfaces>>=
module subroutine process_extract_resonance_history_set &
(process, res_set, include_trivial, i_component)
class(process_t), intent(in), target :: process
type(resonance_history_set_t), intent(out) :: res_set
logical, intent(in), optional :: include_trivial
integer, intent(in), optional :: i_component
end subroutine process_extract_resonance_history_set
<<Process: procedures>>=
module subroutine process_extract_resonance_history_set &
(process, res_set, include_trivial, i_component)
class(process_t), intent(in), target :: process
type(resonance_history_set_t), intent(out) :: res_set
logical, intent(in), optional :: include_trivial
integer, intent(in), optional :: i_component
integer :: i
i = 1; if (present (i_component)) i = i_component
if (process%component(i)%active) then
select type (phs_config => process%get_phs_config (i))
class is (phs_wood_config_t)
call phs_config%extract_resonance_history_set &
(res_set, include_trivial)
class default
call msg_error ("process '" // char (process%get_id ()) &
// "': extract resonance histories: phase-space method must be &
&'wood'. No resonances can be determined.")
end select
end if
end subroutine process_extract_resonance_history_set
@ %def process_extract_resonance_history_set
@ Initialize from a complete beam setup. If the beam setup does not
apply directly to the process, choose a fallback option as a straight
scattering or decay process.
<<Process: process: TBP>>=
procedure :: setup_beams_beam_structure => process_setup_beams_beam_structure
<<Process: sub interfaces>>=
module subroutine process_setup_beams_beam_structure &
(process, beam_structure, sqrts, decay_rest_frame)
class(process_t), intent(inout) :: process
type(beam_structure_t), intent(in) :: beam_structure
real(default), intent(in) :: sqrts
logical, intent(in), optional :: decay_rest_frame
end subroutine process_setup_beams_beam_structure
<<Process: procedures>>=
module subroutine process_setup_beams_beam_structure &
(process, beam_structure, sqrts, decay_rest_frame)
class(process_t), intent(inout) :: process
type(beam_structure_t), intent(in) :: beam_structure
real(default), intent(in) :: sqrts
logical, intent(in), optional :: decay_rest_frame
integer :: n_in
logical :: applies
n_in = process%get_n_in ()
call beam_structure%check_against_n_in (process%get_n_in (), applies)
if (applies) then
call process%beam_config%init_beam_structure &
(beam_structure, sqrts, process%get_model_ptr (), decay_rest_frame)
else if (n_in == 2) then
call process%setup_beams_sqrts (sqrts, beam_structure)
else
call process%setup_beams_decay (decay_rest_frame, beam_structure)
end if
end subroutine process_setup_beams_beam_structure
@ %def process_setup_beams_beam_structure
@ Notify the user about beam setup.
<<Process: process: TBP>>=
procedure :: beams_startup_message => process_beams_startup_message
<<Process: sub interfaces>>=
module subroutine process_beams_startup_message &
(process, unit, beam_structure)
class(process_t), intent(in) :: process
integer, intent(in), optional :: unit
type(beam_structure_t), intent(in), optional :: beam_structure
end subroutine process_beams_startup_message
<<Process: procedures>>=
module subroutine process_beams_startup_message &
(process, unit, beam_structure)
class(process_t), intent(in) :: process
integer, intent(in), optional :: unit
type(beam_structure_t), intent(in), optional :: beam_structure
call process%beam_config%startup_message (unit, beam_structure)
end subroutine process_beams_startup_message
@ %def process_beams_startup_message
@ Initialize phase-space configuration by reading out the environment
variables. We return the rebuild flags and store parameters in the blocks
[[phs_par]] and [[mapping_defs]].
The phase-space configuration object(s) are allocated by [[pcm]].
<<Process: process: TBP>>=
procedure :: init_phs_config => process_init_phs_config
<<Process: sub interfaces>>=
module subroutine process_init_phs_config (process)
class(process_t), intent(inout) :: process
end subroutine process_init_phs_config
<<Process: procedures>>=
module subroutine process_init_phs_config (process)
class(process_t), intent(inout) :: process
type(var_list_t), pointer :: var_list
type(phs_parameters_t) :: phs_par
type(mapping_defaults_t) :: mapping_defs
var_list => process%env%get_var_list_ptr ()
phs_par%m_threshold_s = &
var_list%get_rval (var_str ("phs_threshold_s"))
phs_par%m_threshold_t = &
var_list%get_rval (var_str ("phs_threshold_t"))
phs_par%off_shell = &
var_list%get_ival (var_str ("phs_off_shell"))
phs_par%keep_nonresonant = &
var_list%get_lval (var_str ("?phs_keep_nonresonant"))
phs_par%t_channel = &
var_list%get_ival (var_str ("phs_t_channel"))
mapping_defs%energy_scale = &
var_list%get_rval (var_str ("phs_e_scale"))
mapping_defs%invariant_mass_scale = &
var_list%get_rval (var_str ("phs_m_scale"))
mapping_defs%momentum_transfer_scale = &
var_list%get_rval (var_str ("phs_q_scale"))
mapping_defs%step_mapping = &
var_list%get_lval (var_str ("?phs_step_mapping"))
mapping_defs%step_mapping_exp = &
var_list%get_lval (var_str ("?phs_step_mapping_exp"))
mapping_defs%enable_s_mapping = &
var_list%get_lval (var_str ("?phs_s_mapping"))
associate (pcm => process%pcm)
call pcm%init_phs_config (process%phs_entry, &
process%meta, process%env, phs_par, mapping_defs)
end associate
end subroutine process_init_phs_config
@ %def process_init_phs_config
@ We complete the kinematics configuration after the beam setup, but before we
configure the chain of structure functions. The reason is that we need the
total energy [[sqrts]] for the kinematics, but the structure-function setup
requires the number of channels, which depends on the kinematics
configuration. For instance, the kinematics module may return the need for
parameterizing an s-channel resonance.
<<Process: process: TBP>>=
procedure :: configure_phs => process_configure_phs
<<Process: sub interfaces>>=
module subroutine process_configure_phs (process, rebuild, &
ignore_mismatch, combined_integration, subdir)
class(process_t), intent(inout) :: process
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
logical, intent(in), optional :: combined_integration
type(string_t), intent(in), optional :: subdir
end subroutine process_configure_phs
<<Process: procedures>>=
module subroutine process_configure_phs (process, rebuild, &
ignore_mismatch, combined_integration, subdir)
class(process_t), intent(inout) :: process
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
logical, intent(in), optional :: combined_integration
type(string_t), intent(in), optional :: subdir
real(default) :: sqrts
integer :: i, i_born, nlo_type
class(phs_config_t), pointer :: phs_config_born
sqrts = process%get_sqrts ()
do i = 1, process%meta%n_components
associate (component => process%component(i))
if (component%active) then
select type (pcm => process%pcm)
type is (pcm_default_t)
call component%configure_phs (sqrts, process%beam_config, &
rebuild, ignore_mismatch, subdir)
class is (pcm_nlo_t)
nlo_type = component%config%get_nlo_type ()
select case (nlo_type)
case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION)
call component%configure_phs (sqrts, process%beam_config, &
rebuild, ignore_mismatch, subdir)
call check_and_extend_phs (component)
case (NLO_REAL, NLO_MISMATCH, NLO_DGLAP)
i_born = component%config%get_associated_born ()
if (pcm%component_type(i) /= COMP_REAL_FIN) &
call check_and_extend_phs (component)
call process%component(i_born)%get_phs_config &
(phs_config_born)
select type (config => component%phs_config)
type is (phs_fks_config_t)
select type (phs_config_born)
type is (phs_wood_config_t)
config%md5sum_born_config = &
phs_config_born%md5sum_phs_config
call config%set_born_config (phs_config_born)
call config%set_mode (component%config%get_nlo_type ())
end select
end select
call component%configure_phs (sqrts, &
process%beam_config, rebuild, ignore_mismatch, subdir)
end select
class default
call msg_bug ("process_configure_phs: unsupported PCM type")
end select
end if
end associate
end do
contains
subroutine check_and_extend_phs (component)
type(process_component_t), intent(inout) :: component
if (combined_integration) then
select type (phs_config => component%phs_config)
class is (phs_wood_config_t)
phs_config%is_combined_integration = .true.
call phs_config%increase_n_par ()
end select
end if
end subroutine check_and_extend_phs
end subroutine process_configure_phs
@ %def process_configure_phs
@
<<Process: process: TBP>>=
procedure :: print_phs_startup_message => process_print_phs_startup_message
<<Process: sub interfaces>>=
module subroutine process_print_phs_startup_message (process)
class(process_t), intent(in) :: process
end subroutine process_print_phs_startup_message
<<Process: procedures>>=
module subroutine process_print_phs_startup_message (process)
class(process_t), intent(in) :: process
integer :: i_component
do i_component = 1, process%meta%n_components
associate (component => process%component(i_component))
if (component%active) then
call component%phs_config%startup_message ()
end if
end associate
end do
end subroutine process_print_phs_startup_message
@ %def process_print_phs_startup_message
@ Insert the structure-function configuration data. First allocate the
storage, then insert data one by one. The third procedure declares a
mapping (of the MC input parameters) for a specific channel and
structure-function combination.
We take the number of channels from the corresponding entry in the
[[config_data]] section.
Otherwise, these a simple wrapper routines. The extra level in the
call tree may allow for simple addressing of multiple concurrent beam
configurations, not implemented currently.
If we do not want structure functions, we simply do not call those procedures.
<<Process: process: TBP>>=
procedure :: init_sf_chain => process_init_sf_chain
generic :: set_sf_channel => set_sf_channel_single
procedure :: set_sf_channel_single => process_set_sf_channel
generic :: set_sf_channel => set_sf_channel_array
procedure :: set_sf_channel_array => process_set_sf_channel_array
<<Process: sub interfaces>>=
module subroutine process_init_sf_chain (process, sf_config, sf_trace_file)
class(process_t), intent(inout) :: process
type(sf_config_t), dimension(:), intent(in) :: sf_config
type(string_t), intent(in), optional :: sf_trace_file
end subroutine process_init_sf_chain
module subroutine process_set_sf_channel (process, c, sf_channel)
class(process_t), intent(inout) :: process
integer, intent(in) :: c
type(sf_channel_t), intent(in) :: sf_channel
end subroutine process_set_sf_channel
module subroutine process_set_sf_channel_array (process, sf_channel)
class(process_t), intent(inout) :: process
type(sf_channel_t), dimension(:), intent(in) :: sf_channel
end subroutine process_set_sf_channel_array
<<Process: procedures>>=
module subroutine process_init_sf_chain (process, sf_config, sf_trace_file)
class(process_t), intent(inout) :: process
type(sf_config_t), dimension(:), intent(in) :: sf_config
type(string_t), intent(in), optional :: sf_trace_file
type(string_t) :: file
if (present (sf_trace_file)) then
if (sf_trace_file /= "") then
file = sf_trace_file
else
file = process%get_id () // "_sftrace.dat"
end if
call process%beam_config%init_sf_chain (sf_config, file)
else
call process%beam_config%init_sf_chain (sf_config)
end if
end subroutine process_init_sf_chain
module subroutine process_set_sf_channel (process, c, sf_channel)
class(process_t), intent(inout) :: process
integer, intent(in) :: c
type(sf_channel_t), intent(in) :: sf_channel
call process%beam_config%set_sf_channel (c, sf_channel)
end subroutine process_set_sf_channel
module subroutine process_set_sf_channel_array (process, sf_channel)
class(process_t), intent(inout) :: process
type(sf_channel_t), dimension(:), intent(in) :: sf_channel
integer :: c
call process%beam_config%allocate_sf_channels (size (sf_channel))
do c = 1, size (sf_channel)
call process%beam_config%set_sf_channel (c, sf_channel(c))
end do
end subroutine process_set_sf_channel_array
@ %def process_init_sf_chain
@ %def process_set_sf_channel
@ Notify about the structure-function setup.
<<Process: process: TBP>>=
procedure :: sf_startup_message => process_sf_startup_message
<<Process: sub interfaces>>=
module subroutine process_sf_startup_message (process, sf_string, unit)
class(process_t), intent(in) :: process
type(string_t), intent(in) :: sf_string
integer, intent(in), optional :: unit
end subroutine process_sf_startup_message
<<Process: procedures>>=
module subroutine process_sf_startup_message (process, sf_string, unit)
class(process_t), intent(in) :: process
type(string_t), intent(in) :: sf_string
integer, intent(in), optional :: unit
call process%beam_config%sf_startup_message (sf_string, unit)
end subroutine process_sf_startup_message
@ %def process_sf_startup_message
@ As soon as both the kinematics configuration and the
structure-function setup are complete, we match parameterizations
(channels) for both. The matching entries are (re)set in the
[[component]] phase-space configuration, while the structure-function
configuration is left intact.
<<Process: process: TBP>>=
procedure :: collect_channels => process_collect_channels
<<Process: sub interfaces>>=
module subroutine process_collect_channels (process, coll)
class(process_t), intent(inout) :: process
type(phs_channel_collection_t), intent(inout) :: coll
end subroutine process_collect_channels
<<Process: procedures>>=
module subroutine process_collect_channels (process, coll)
class(process_t), intent(inout) :: process
type(phs_channel_collection_t), intent(inout) :: coll
integer :: i
do i = 1, process%meta%n_components
associate (component => process%component(i))
if (component%active) &
call component%collect_channels (coll)
end associate
end do
end subroutine process_collect_channels
@ %def process_collect_channels
@ Independently, we should be able to check if any component does not
contain phase-space parameters. Such a process can only be integrated
if there are structure functions.
<<Process: process: TBP>>=
procedure :: contains_trivial_component => process_contains_trivial_component
<<Process: sub interfaces>>=
module function process_contains_trivial_component (process) result (flag)
class(process_t), intent(in) :: process
logical :: flag
end function process_contains_trivial_component
<<Process: procedures>>=
module function process_contains_trivial_component (process) result (flag)
class(process_t), intent(in) :: process
logical :: flag
integer :: i
flag = .true.
do i = 1, process%meta%n_components
associate (component => process%component(i))
if (component%active) then
if (component%get_n_phs_par () == 0) return
end if
end associate
end do
flag = .false.
end function process_contains_trivial_component
@ %def process_contains_trivial_component
@
<<Process: process: TBP>>=
procedure :: get_master_component => process_get_master_component
<<Process: sub interfaces>>=
module function process_get_master_component &
(process, i_mci) result (i_component)
integer :: i_component
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
end function process_get_master_component
<<Process: procedures>>=
module function process_get_master_component &
(process, i_mci) result (i_component)
integer :: i_component
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
integer :: i
i_component = 0
do i = 1, size (process%component)
if (process%component(i)%i_mci == i_mci) then
i_component = i
return
end if
end do
end function process_get_master_component
@ %def process_get_master_component
@ Determine the MC parameter set structure and the MCI configuration for each
process component. We need data from the structure-function and phase-space
setup, so those should be complete before this is called. We also
make a random-number generator instance for each MCI group.
<<Process: process: TBP>>=
procedure :: setup_mci => process_setup_mci
<<Process: sub interfaces>>=
module subroutine process_setup_mci (process, dispatch_mci)
class(process_t), intent(inout) :: process
procedure(dispatch_mci_proc) :: dispatch_mci
end subroutine process_setup_mci
<<Process: procedures>>=
module subroutine process_setup_mci (process, dispatch_mci)
class(process_t), intent(inout) :: process
procedure(dispatch_mci_proc) :: dispatch_mci
class(mci_t), allocatable :: mci_template
integer :: i, i_mci
if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_setup_mci")
associate (pcm => process%pcm)
call pcm%call_dispatch_mci (dispatch_mci, &
process%get_var_list_ptr (), process%meta%id, mci_template)
call pcm%setup_mci (process%mci_entry)
process%config%n_mci = pcm%n_mci
process%component(:)%i_mci = pcm%i_mci(:)
do i = 1, pcm%n_components
i_mci = process%pcm%i_mci(i)
if (i_mci > 0) then
associate (component => process%component(i), &
mci_entry => process%mci_entry(i_mci))
call mci_entry%configure (mci_template, &
process%meta%type, &
i_mci, i, component, process%beam_config%n_sfpar, &
process%rng_factory)
call mci_entry%set_parameters (process%get_var_list_ptr ())
end associate
end if
end do
end associate
end subroutine process_setup_mci
@ %def process_setup_mci
@ Set cuts. This is a parse node, namely the right-hand side of the [[cut]]
assignment. When creating an instance, we compile this into an evaluation
tree. The parse node may be null.
<<Process: process: TBP>>=
procedure :: set_cuts => process_set_cuts
<<Process: sub interfaces>>=
module subroutine process_set_cuts (process, ef_cuts)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_cuts
end subroutine process_set_cuts
<<Process: procedures>>=
module subroutine process_set_cuts (process, ef_cuts)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_cuts
allocate (process%config%ef_cuts, source = ef_cuts)
end subroutine process_set_cuts
@ %def process_set_cuts
@ Analogously for the other expressions.
<<Process: process: TBP>>=
procedure :: set_scale => process_set_scale
procedure :: set_fac_scale => process_set_fac_scale
procedure :: set_ren_scale => process_set_ren_scale
procedure :: set_weight => process_set_weight
<<Process: sub interfaces>>=
module subroutine process_set_scale (process, ef_scale)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_scale
end subroutine process_set_scale
module subroutine process_set_weight (process, ef_weight)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_weight
end subroutine process_set_weight
module subroutine process_set_fac_scale (process, ef_fac_scale)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_fac_scale
end subroutine process_set_fac_scale
module subroutine process_set_ren_scale (process, ef_ren_scale)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_ren_scale
end subroutine process_set_ren_scale
<<Process: procedures>>=
module subroutine process_set_scale (process, ef_scale)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_scale
allocate (process%config%ef_scale, source = ef_scale)
end subroutine process_set_scale
module subroutine process_set_fac_scale (process, ef_fac_scale)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_fac_scale
allocate (process%config%ef_fac_scale, source = ef_fac_scale)
end subroutine process_set_fac_scale
module subroutine process_set_ren_scale (process, ef_ren_scale)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_ren_scale
allocate (process%config%ef_ren_scale, source = ef_ren_scale)
end subroutine process_set_ren_scale
module subroutine process_set_weight (process, ef_weight)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_weight
allocate (process%config%ef_weight, source = ef_weight)
end subroutine process_set_weight
@ %def process_set_scale
@ %def process_set_fac_scale
@ %def process_set_ren_scale
@ %def process_set_weight
@
\subsubsection{MD5 sum}
The MD5 sum of the process object should reflect the state completely,
including integration results. It is used for checking the integrity
of event files. This global checksum includes checksums for the
various parts. In particular, the MCI object receives a checksum that
includes the configuration of all configuration parts relevant for an
individual integration. This checksum is used for checking the
integrity of integration grids.
We do not need MD5 sums for the process terms, since these are
generated from the component definitions.
<<Process: process: TBP>>=
procedure :: compute_md5sum => process_compute_md5sum
<<Process: sub interfaces>>=
module subroutine process_compute_md5sum (process)
class(process_t), intent(inout) :: process
end subroutine process_compute_md5sum
<<Process: procedures>>=
module subroutine process_compute_md5sum (process)
class(process_t), intent(inout) :: process
integer :: i
call process%config%compute_md5sum ()
do i = 1, process%config%n_components
associate (component => process%component(i))
if (component%active) then
call component%compute_md5sum ()
end if
end associate
end do
call process%beam_config%compute_md5sum ()
do i = 1, process%config%n_mci
call process%mci_entry(i)%compute_md5sum &
(process%config, process%component, process%beam_config)
end do
end subroutine process_compute_md5sum
@ %def process_compute_md5sum
@
<<Process: process: TBP>>=
procedure :: sampler_test => process_sampler_test
<<Process: sub interfaces>>=
module subroutine process_sampler_test (process, sampler, n_calls, i_mci)
class(process_t), intent(inout) :: process
class(mci_sampler_t), intent(inout) :: sampler
integer, intent(in) :: n_calls, i_mci
end subroutine process_sampler_test
<<Process: procedures>>=
module subroutine process_sampler_test (process, sampler, n_calls, i_mci)
class(process_t), intent(inout) :: process
class(mci_sampler_t), intent(inout) :: sampler
integer, intent(in) :: n_calls, i_mci
call process%mci_entry(i_mci)%sampler_test (sampler, n_calls)
end subroutine process_sampler_test
@ %def process_sampler_test
@ The finalizer should be called after all integration passes have been
completed. It will, for instance, write a summary of the integration
results.
[[integrate_dummy]] does a ``dummy'' integration in the sense that
nothing is done but just empty integration results appended.
<<Process: process: TBP>>=
procedure :: final_integration => process_final_integration
procedure :: integrate_dummy => process_integrate_dummy
<<Process: sub interfaces>>=
module subroutine process_final_integration (process, i_mci)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
end subroutine process_final_integration
module subroutine process_integrate_dummy (process)
class(process_t), intent(inout) :: process
end subroutine process_integrate_dummy
<<Process: procedures>>=
module subroutine process_final_integration (process, i_mci)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
call process%mci_entry(i_mci)%final_integration ()
end subroutine process_final_integration
module subroutine process_integrate_dummy (process)
class(process_t), intent(inout) :: process
type(integration_results_t) :: results
integer :: u_log
u_log = logfile_unit ()
call results%init (process%meta%type)
call results%display_init (screen = .true., unit = u_log)
call results%new_pass ()
call results%record (1, 0, 0._default, 0._default, 0._default)
call results%display_final ()
end subroutine process_integrate_dummy
@ %def process_final_integration
@ %def process_integrate_dummy
@
<<Process: process: TBP>>=
procedure :: integrate => process_integrate
<<Process: sub interfaces>>=
module subroutine process_integrate (process, i_mci, mci_work, &
mci_sampler, n_it, n_calls, adapt_grids, adapt_weights, final, &
pacify, nlo_type)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
type(mci_work_t), intent(inout) :: mci_work
class(mci_sampler_t), intent(inout) :: mci_sampler
integer, intent(in) :: n_it, n_calls
logical, intent(in), optional :: adapt_grids, adapt_weights
logical, intent(in), optional :: final
logical, intent(in), optional :: pacify
integer, intent(in), optional :: nlo_type
end subroutine process_integrate
<<Process: procedures>>=
module subroutine process_integrate (process, i_mci, mci_work, &
mci_sampler, n_it, n_calls, adapt_grids, adapt_weights, final, &
pacify, nlo_type)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
type(mci_work_t), intent(inout) :: mci_work
class(mci_sampler_t), intent(inout) :: mci_sampler
integer, intent(in) :: n_it, n_calls
logical, intent(in), optional :: adapt_grids, adapt_weights
logical, intent(in), optional :: final
logical, intent(in), optional :: pacify
integer, intent(in), optional :: nlo_type
associate (mci_entry => process%mci_entry(i_mci))
call mci_entry%integrate (mci_work%mci, mci_sampler, n_it, n_calls, &
adapt_grids, adapt_weights, final, pacify, &
nlo_type = nlo_type)
call mci_entry%results%display_pass (pacify)
end associate
end subroutine process_integrate
@ %def process_integrate
@
<<Process: process: TBP>>=
procedure :: generate_weighted_event => process_generate_weighted_event
<<Process: sub interfaces>>=
module subroutine process_generate_weighted_event (process, i_mci, &
mci_work, mci_sampler, keep_failed_events)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
type(mci_work_t), intent(inout) :: mci_work
class(mci_sampler_t), intent(inout) :: mci_sampler
logical, intent(in) :: keep_failed_events
end subroutine process_generate_weighted_event
<<Process: procedures>>=
module subroutine process_generate_weighted_event (process, i_mci, &
mci_work, mci_sampler, keep_failed_events)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
type(mci_work_t), intent(inout) :: mci_work
class(mci_sampler_t), intent(inout) :: mci_sampler
logical, intent(in) :: keep_failed_events
associate (mci_entry => process%mci_entry(i_mci))
call mci_entry%generate_weighted_event (mci_work%mci, &
mci_sampler, keep_failed_events)
end associate
end subroutine process_generate_weighted_event
@ %def process_generate_weighted_event
<<Process: process: TBP>>=
procedure :: generate_unweighted_event => process_generate_unweighted_event
<<Process: sub interfaces>>=
module subroutine process_generate_unweighted_event (process, i_mci, &
mci_work, mci_sampler)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
type(mci_work_t), intent(inout) :: mci_work
class(mci_sampler_t), intent(inout) :: mci_sampler
end subroutine process_generate_unweighted_event
<<Process: procedures>>=
module subroutine process_generate_unweighted_event (process, i_mci, &
mci_work, mci_sampler)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
type(mci_work_t), intent(inout) :: mci_work
class(mci_sampler_t), intent(inout) :: mci_sampler
associate (mci_entry => process%mci_entry(i_mci))
call mci_entry%generate_unweighted_event &
(mci_work%mci, mci_sampler)
end associate
end subroutine process_generate_unweighted_event
@ %def process_generate_unweighted_event
@ Display the final results for the sum of all components. This is useful,
obviously, only if there is more than one component and not if a combined
integration of all components together has been performed.
<<Process: process: TBP>>=
procedure :: display_summed_results => process_display_summed_results
<<Process: sub interfaces>>=
module subroutine process_display_summed_results (process, pacify)
class(process_t), intent(inout) :: process
logical, intent(in) :: pacify
end subroutine process_display_summed_results
<<Process: procedures>>=
module subroutine process_display_summed_results (process, pacify)
class(process_t), intent(inout) :: process
logical, intent(in) :: pacify
type(integration_results_t) :: results
integer :: u_log
u_log = logfile_unit ()
call results%init (process%meta%type)
call results%display_init (screen = .true., unit = u_log)
call results%new_pass ()
call results%record (1, 0, &
process%get_integral (), &
process%get_error (), &
process%get_efficiency (), suppress = pacify)
select type (pcm => process%pcm)
class is (pcm_nlo_t)
!!! Check that Born integral is there
if (.not. pcm%settings%combined_integration .and. &
process%component_can_be_integrated (1)) then
call results%record_correction (process%get_correction (), &
process%get_correction_error ())
end if
end select
call results%display_final ()
end subroutine process_display_summed_results
@ %def process_display_summed_results
@ Run LaTeX/Metapost to generate a ps/pdf file for the integration
history. We (re)write the driver file -- just in case it has been
missed before -- then we compile it.
<<Process: process: TBP>>=
procedure :: display_integration_history => &
process_display_integration_history
<<Process: sub interfaces>>=
module subroutine process_display_integration_history &
(process, i_mci, filename, os_data, eff_reset)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
type(string_t), intent(in) :: filename
type(os_data_t), intent(in) :: os_data
logical, intent(in), optional :: eff_reset
end subroutine process_display_integration_history
<<Process: procedures>>=
module subroutine process_display_integration_history &
(process, i_mci, filename, os_data, eff_reset)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
type(string_t), intent(in) :: filename
type(os_data_t), intent(in) :: os_data
logical, intent(in), optional :: eff_reset
call integration_results_write_driver &
(process%mci_entry(i_mci)%results, filename, eff_reset)
call integration_results_compile_driver &
(process%mci_entry(i_mci)%results, filename, os_data)
end subroutine process_display_integration_history
@ %def subroutine process_display_integration_history
@ Write a complete logfile (with hardcoded name based on the process ID).
We do not write internal data.
<<Process: process: TBP>>=
procedure :: write_logfile => process_write_logfile
<<Process: sub interfaces>>=
module subroutine process_write_logfile (process, i_mci, filename)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
type(string_t), intent(in) :: filename
end subroutine process_write_logfile
<<Process: procedures>>=
module subroutine process_write_logfile (process, i_mci, filename)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
type(string_t), intent(in) :: filename
type(time_t) :: time
integer :: unit, u
unit = free_unit ()
open (unit = unit, file = char (filename), action = "write", &
status = "replace")
u = given_output_unit (unit)
write (u, "(A)") repeat ("#", 79)
call process%meta%write (u, .false.)
write (u, "(A)") repeat ("#", 79)
write (u, "(3x,A,ES17.10)") "Integral = ", &
process%mci_entry(i_mci)%get_integral ()
write (u, "(3x,A,ES17.10)") "Error = ", &
process%mci_entry(i_mci)%get_error ()
write (u, "(3x,A,ES17.10)") "Accuracy = ", &
process%mci_entry(i_mci)%get_accuracy ()
write (u, "(3x,A,ES17.10)") "Chi2 = ", &
process%mci_entry(i_mci)%get_chi2 ()
write (u, "(3x,A,ES17.10)") "Efficiency = ", &
process%mci_entry(i_mci)%get_efficiency ()
call process%mci_entry(i_mci)%get_time (time, 10000)
if (time%is_known ()) then
write (u, "(3x,A,1x,A)") "T(10k evt) = ", char (time%to_string_dhms ())
else
write (u, "(3x,A)") "T(10k evt) = [undefined]"
end if
call process%mci_entry(i_mci)%results%write (u)
write (u, "(A)") repeat ("#", 79)
call process%mci_entry(i_mci)%results%write_chain_weights (u)
write (u, "(A)") repeat ("#", 79)
call process%mci_entry(i_mci)%counter%write (u)
write (u, "(A)") repeat ("#", 79)
call process%mci_entry(i_mci)%mci%write_log_entry (u)
write (u, "(A)") repeat ("#", 79)
call process%beam_config%data%write (u)
write (u, "(A)") repeat ("#", 79)
if (allocated (process%config%ef_cuts)) then
write (u, "(3x,A)") "Cut expression:"
call process%config%ef_cuts%write (u)
else
write (u, "(3x,A)") "No cuts used."
end if
call write_separator (u)
if (allocated (process%config%ef_scale)) then
write (u, "(3x,A)") "Scale expression:"
call process%config%ef_scale%write (u)
else
write (u, "(3x,A)") "No scale expression was given."
end if
call write_separator (u)
if (allocated (process%config%ef_fac_scale)) then
write (u, "(3x,A)") "Factorization scale expression:"
call process%config%ef_fac_scale%write (u)
else
write (u, "(3x,A)") "No factorization scale expression was given."
end if
call write_separator (u)
if (allocated (process%config%ef_ren_scale)) then
write (u, "(3x,A)") "Renormalization scale expression:"
call process%config%ef_ren_scale%write (u)
else
write (u, "(3x,A)") "No renormalization scale expression was given."
end if
call write_separator (u)
if (allocated (process%config%ef_weight)) then
call write_separator (u)
write (u, "(3x,A)") "Weight expression:"
call process%config%ef_weight%write (u)
else
write (u, "(3x,A)") "No weight expression was given."
end if
write (u, "(A)") repeat ("#", 79)
write (u, "(1x,A)") "Summary of quantum-number states:"
write (u, "(1x,A)") " + sign: allowed and contributing"
write (u, "(1x,A)") " no + : switched off at runtime"
call process%write_state_summary (u)
write (u, "(A)") repeat ("#", 79)
call process%env%write (u, show_var_list=.true., &
show_model=.false., show_lib=.false., show_os_data=.false.)
write (u, "(A)") repeat ("#", 79)
close (u)
end subroutine process_write_logfile
@ %def process_write_logfile
@ Display the quantum-number combinations of the process components, and their
current status (allowed or switched off).
<<Process: process: TBP>>=
procedure :: write_state_summary => process_write_state_summary
<<Process: sub interfaces>>=
module subroutine process_write_state_summary (process, unit)
class(process_t), intent(in) :: process
integer, intent(in), optional :: unit
end subroutine process_write_state_summary
<<Process: procedures>>=
module subroutine process_write_state_summary (process, unit)
class(process_t), intent(in) :: process
integer, intent(in), optional :: unit
integer :: i, i_component, u
u = given_output_unit (unit)
do i = 1, size (process%term)
call write_separator (u)
i_component = process%term(i)%i_component
if (i_component /= 0) then
call process%term(i)%write_state_summary &
(process%get_core_term(i), unit)
end if
end do
end subroutine process_write_state_summary
@ %def process_write_state_summary
@ Prepare event generation for the specified MCI entry. This implies, in
particular, checking the phase-space file.
<<Process: process: TBP>>=
procedure :: prepare_simulation => process_prepare_simulation
<<Process: sub interfaces>>=
module subroutine process_prepare_simulation (process, i_mci)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
end subroutine process_prepare_simulation
<<Process: procedures>>=
module subroutine process_prepare_simulation (process, i_mci)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
call process%mci_entry(i_mci)%prepare_simulation ()
end subroutine process_prepare_simulation
@ %def process_prepare_simulation
@
\subsubsection{Retrieve process data}
Tell whether integral (and error) are known.
<<Process: process: TBP>>=
generic :: has_integral => has_integral_tot, has_integral_mci
procedure :: has_integral_tot => process_has_integral_tot
procedure :: has_integral_mci => process_has_integral_mci
<<Process: sub interfaces>>=
module function process_has_integral_tot (process) result (flag)
logical :: flag
class(process_t), intent(in) :: process
end function process_has_integral_tot
module function process_has_integral_mci (process, i_mci) result (flag)
logical :: flag
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
end function process_has_integral_mci
<<Process: procedures>>=
module function process_has_integral_mci (process, i_mci) result (flag)
logical :: flag
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
if (allocated (process%mci_entry)) then
flag = process%mci_entry(i_mci)%has_integral ()
else
flag = .false.
end if
end function process_has_integral_mci
module function process_has_integral_tot (process) result (flag)
logical :: flag
class(process_t), intent(in) :: process
integer :: i, j, i_component
if (allocated (process%mci_entry)) then
flag = .true.
do i = 1, size (process%mci_entry)
do j = 1, size (process%mci_entry(i)%i_component)
i_component = process%mci_entry(i)%i_component(j)
if (process%component_can_be_integrated (i_component)) &
flag = flag .and. process%mci_entry(i)%has_integral ()
end do
end do
else
flag = .false.
end if
end function process_has_integral_tot
@ %def process_has_integral
@
Return the current integral and error obtained by the integrator [[i_mci]].
<<Process: process: TBP>>=
generic :: get_integral => get_integral_tot, get_integral_mci
generic :: get_error => get_error_tot, get_error_mci
generic :: get_efficiency => get_efficiency_tot, get_efficiency_mci
procedure :: get_integral_tot => process_get_integral_tot
procedure :: get_integral_mci => process_get_integral_mci
procedure :: get_error_tot => process_get_error_tot
procedure :: get_error_mci => process_get_error_mci
procedure :: get_efficiency_tot => process_get_efficiency_tot
procedure :: get_efficiency_mci => process_get_efficiency_mci
<<Process: sub interfaces>>=
module function process_get_integral_mci (process, i_mci) result (integral)
real(default) :: integral
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
end function process_get_integral_mci
module function process_get_error_mci (process, i_mci) result (error)
real(default) :: error
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
end function process_get_error_mci
module function process_get_efficiency_mci &
(process, i_mci) result (efficiency)
real(default) :: efficiency
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
end function process_get_efficiency_mci
module function process_get_integral_tot (process) result (integral)
real(default) :: integral
class(process_t), intent(in) :: process
end function process_get_integral_tot
module function process_get_error_tot (process) result (error)
real(default) :: variance
class(process_t), intent(in) :: process
real(default) :: error
end function process_get_error_tot
module function process_get_efficiency_tot (process) result (efficiency)
real(default) :: efficiency
class(process_t), intent(in) :: process
end function process_get_efficiency_tot
<<Process: procedures>>=
module function process_get_integral_mci (process, i_mci) result (integral)
real(default) :: integral
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
integral = process%mci_entry(i_mci)%get_integral ()
end function process_get_integral_mci
module function process_get_error_mci (process, i_mci) result (error)
real(default) :: error
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
error = process%mci_entry(i_mci)%get_error ()
end function process_get_error_mci
module function process_get_efficiency_mci &
(process, i_mci) result (efficiency)
real(default) :: efficiency
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
efficiency = process%mci_entry(i_mci)%get_efficiency ()
end function process_get_efficiency_mci
module function process_get_integral_tot (process) result (integral)
real(default) :: integral
class(process_t), intent(in) :: process
integer :: i, j, i_component
integral = zero
if (allocated (process%mci_entry)) then
do i = 1, size (process%mci_entry)
do j = 1, size (process%mci_entry(i)%i_component)
i_component = process%mci_entry(i)%i_component(j)
if (process%component_can_be_integrated(i_component)) &
integral = integral + process%mci_entry(i)%get_integral ()
end do
end do
end if
end function process_get_integral_tot
module function process_get_error_tot (process) result (error)
real(default) :: variance
class(process_t), intent(in) :: process
real(default) :: error
integer :: i, j, i_component
variance = zero
if (allocated (process%mci_entry)) then
do i = 1, size (process%mci_entry)
do j = 1, size (process%mci_entry(i)%i_component)
i_component = process%mci_entry(i)%i_component(j)
if (process%component_can_be_integrated(i_component)) &
variance = variance + process%mci_entry(i)%get_error () ** 2
end do
end do
end if
error = sqrt (variance)
end function process_get_error_tot
module function process_get_efficiency_tot (process) result (efficiency)
real(default) :: efficiency
class(process_t), intent(in) :: process
real(default) :: den, eff, int
integer :: i, j, i_component
den = zero
if (allocated (process%mci_entry)) then
do i = 1, size (process%mci_entry)
do j = 1, size (process%mci_entry(i)%i_component)
i_component = process%mci_entry(i)%i_component(j)
if (process%component_can_be_integrated(i_component)) then
int = process%get_integral (i)
if (int > 0) then
eff = process%mci_entry(i)%get_efficiency ()
if (eff > 0) then
den = den + int / eff
else
efficiency = 0
return
end if
end if
end if
end do
end do
end if
if (den > 0) then
efficiency = process%get_integral () / den
else
efficiency = 0
end if
end function process_get_efficiency_tot
@ %def process_get_integral process_get_efficiency
@ Let us call the ratio of the NLO and the LO result $\iota = I_{NLO}
/ I_{LO}$. Then usual error propagation gives
\begin{equation*}
\sigma_{\iota}^2 = \left(\frac{\partial \iota}{\partial
I_{LO}}\right)^2 \sigma_{I_{LO}}^2
+ \left(\frac{\partial \iota}{\partial
I_{NLO}}\right)^2 \sigma_{I_{NLO}}^2
= \frac{I_{NLO}^2\sigma_{I_{LO}}^2}{I_{LO}^4} +
\frac{\sigma_{I_{NLO}}^2}{I_{LO}^2}.
\end{equation*}
<<Process: process: TBP>>=
procedure :: get_correction => process_get_correction
procedure :: get_correction_error => process_get_correction_error
<<Process: sub interfaces>>=
module function process_get_correction (process) result (ratio)
real(default) :: ratio
class(process_t), intent(in) :: process
end function process_get_correction
module function process_get_correction_error (process) result (error)
real(default) :: error
class(process_t), intent(in) :: process
end function process_get_correction_error
<<Process: procedures>>=
module function process_get_correction (process) result (ratio)
real(default) :: ratio
class(process_t), intent(in) :: process
integer :: i_mci, i_component
real(default) :: int_born, int_nlo
int_nlo = zero
int_born = process%mci_entry(1)%get_integral ()
i_mci = 2
do i_component = 2, size (process%component)
if (process%component_can_be_integrated (i_component)) then
int_nlo = int_nlo + process%mci_entry(i_mci)%get_integral ()
i_mci = i_mci + 1
end if
end do
ratio = int_nlo / int_born * 100
end function process_get_correction
module function process_get_correction_error (process) result (error)
real(default) :: error
class(process_t), intent(in) :: process
real(default) :: int_born, sum_int_nlo
real(default) :: err_born, err2
integer :: i_mci, i_component
sum_int_nlo = zero; err2 = zero
int_born = process%mci_entry(1)%get_integral ()
err_born = process%mci_entry(1)%get_error ()
i_mci = 2
do i_component = 2, size (process%component)
if (process%component_can_be_integrated (i_component)) then
sum_int_nlo = sum_int_nlo + process%mci_entry(i_mci)%get_integral ()
err2 = err2 + process%mci_entry(i_mci)%get_error()**2
i_mci = i_mci + 1
end if
end do
error = sqrt (err2 / int_born**2 + sum_int_nlo**2 * err_born**2 / int_born**4) * 100
end function process_get_correction_error
@ %def process_get_correction process_get_correction_error
@ This routine asks [[beam_config]] for the frame.
<<Process: process: TBP>>=
procedure :: lab_is_cm => process_lab_is_cm
<<Process: sub interfaces>>=
pure module function process_lab_is_cm (process) result (lab_is_cm)
logical :: lab_is_cm
class(process_t), intent(in) :: process
end function process_lab_is_cm
<<Process: procedures>>=
pure module function process_lab_is_cm (process) result (lab_is_cm)
logical :: lab_is_cm
class(process_t), intent(in) :: process
lab_is_cm = process%beam_config%lab_is_cm
end function process_lab_is_cm
@ %def process_lab_is_cm
@
<<Process: process: TBP>>=
procedure :: get_component_ptr => process_get_component_ptr
<<Process: sub interfaces>>=
module function process_get_component_ptr (process, i) result (component)
type(process_component_t), pointer :: component
class(process_t), intent(in), target :: process
integer, intent(in) :: i
end function process_get_component_ptr
<<Process: procedures>>=
module function process_get_component_ptr (process, i) result (component)
type(process_component_t), pointer :: component
class(process_t), intent(in), target :: process
integer, intent(in) :: i
component => process%component(i)
end function process_get_component_ptr
@ %def process_get_component_ptr
@
<<Process: process: TBP>>=
procedure :: get_qcd => process_get_qcd
<<Process: sub interfaces>>=
module function process_get_qcd (process) result (qcd)
type(qcd_t) :: qcd
class(process_t), intent(in) :: process
end function process_get_qcd
<<Process: procedures>>=
module function process_get_qcd (process) result (qcd)
type(qcd_t) :: qcd
class(process_t), intent(in) :: process
qcd = process%config%get_qcd ()
end function process_get_qcd
@ %def process_get_qcd
@
<<Process: process: TBP>>=
generic :: get_component_type => get_component_type_single
procedure :: get_component_type_single => process_get_component_type_single
<<Process: sub interfaces>>=
elemental module function process_get_component_type_single &
(process, i_component) result (comp_type)
integer :: comp_type
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
end function process_get_component_type_single
<<Process: procedures>>=
elemental module function process_get_component_type_single &
(process, i_component) result (comp_type)
integer :: comp_type
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
comp_type = process%component(i_component)%component_type
end function process_get_component_type_single
@ %def process_get_component_type_single
@
<<Process: process: TBP>>=
generic :: get_component_type => get_component_type_all
procedure :: get_component_type_all => process_get_component_type_all
<<Process: sub interfaces>>=
module function process_get_component_type_all &
(process) result (comp_type)
integer, dimension(:), allocatable :: comp_type
class(process_t), intent(in) :: process
end function process_get_component_type_all
<<Process: procedures>>=
module function process_get_component_type_all &
(process) result (comp_type)
integer, dimension(:), allocatable :: comp_type
class(process_t), intent(in) :: process
allocate (comp_type (size (process%component)))
comp_type = process%component%component_type
end function process_get_component_type_all
@ %def process_get_component_type_all
@
<<Process: process: TBP>>=
procedure :: get_component_i_terms => process_get_component_i_terms
<<Process: sub interfaces>>=
module function process_get_component_i_terms &
(process, i_component) result (i_term)
integer, dimension(:), allocatable :: i_term
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
end function process_get_component_i_terms
<<Process: procedures>>=
module function process_get_component_i_terms &
(process, i_component) result (i_term)
integer, dimension(:), allocatable :: i_term
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
allocate (i_term (size (process%component(i_component)%i_term)))
i_term = process%component(i_component)%i_term
end function process_get_component_i_terms
@ %def process_get_component_i_terms
@
<<Process: process: TBP>>=
procedure :: get_n_allowed_born => process_get_n_allowed_born
<<Process: sub interfaces>>=
module function process_get_n_allowed_born (process, i_born) result (n_born)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_born
integer :: n_born
end function process_get_n_allowed_born
<<Process: procedures>>=
module function process_get_n_allowed_born (process, i_born) result (n_born)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_born
integer :: n_born
n_born = process%term(i_born)%n_allowed
end function process_get_n_allowed_born
@ %def process_get_n_allowed_born
@ Workaround getter. Would be better to remove this.
<<Process: process: TBP>>=
procedure :: get_pcm_ptr => process_get_pcm_ptr
<<Process: sub interfaces>>=
module function process_get_pcm_ptr (process) result (pcm)
class(pcm_t), pointer :: pcm
class(process_t), intent(in), target :: process
end function process_get_pcm_ptr
<<Process: procedures>>=
module function process_get_pcm_ptr (process) result (pcm)
class(pcm_t), pointer :: pcm
class(process_t), intent(in), target :: process
pcm => process%pcm
end function process_get_pcm_ptr
@ %def process_get_pcm_ptr
<<Process: process: TBP>>=
generic :: component_can_be_integrated => component_can_be_integrated_single
generic :: component_can_be_integrated => component_can_be_integrated_all
procedure :: component_can_be_integrated_single => &
process_component_can_be_integrated_single
<<Process: sub interfaces>>=
module function process_component_can_be_integrated_single &
(process, i_component) result (active)
logical :: active
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
end function process_component_can_be_integrated_single
<<Process: procedures>>=
module function process_component_can_be_integrated_single &
(process, i_component) result (active)
logical :: active
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
logical :: combined_integration
select type (pcm => process%pcm)
type is (pcm_nlo_t)
combined_integration = pcm%settings%combined_integration
class default
combined_integration = .false.
end select
associate (component => process%component(i_component))
active = component%can_be_integrated ()
if (combined_integration) &
active = active .and. component%component_type <= COMP_MASTER
end associate
end function process_component_can_be_integrated_single
@ %def process_component_can_be_integrated_single
@
<<Process: process: TBP>>=
procedure :: component_can_be_integrated_all => &
process_component_can_be_integrated_all
<<Process: sub interfaces>>=
module function process_component_can_be_integrated_all &
(process) result (val)
logical, dimension(:), allocatable :: val
class(process_t), intent(in) :: process
end function process_component_can_be_integrated_all
<<Process: procedures>>=
module function process_component_can_be_integrated_all (process) result (val)
logical, dimension(:), allocatable :: val
class(process_t), intent(in) :: process
integer :: i
allocate (val (size (process%component)))
do i = 1, size (process%component)
val(i) = process%component_can_be_integrated (i)
end do
end function process_component_can_be_integrated_all
@ %def process_component_can_be_integrated_all
@
<<Process: process: TBP>>=
procedure :: reset_selected_cores => process_reset_selected_cores
<<Process: sub interfaces>>=
pure module subroutine process_reset_selected_cores (process)
class(process_t), intent(inout) :: process
end subroutine process_reset_selected_cores
<<Process: procedures>>=
pure module subroutine process_reset_selected_cores (process)
class(process_t), intent(inout) :: process
process%pcm%component_selected = .false.
end subroutine process_reset_selected_cores
@ %def process_reset_selected_cores
@
<<Process: process: TBP>>=
procedure :: select_components => process_select_components
<<Process: sub interfaces>>=
pure module subroutine process_select_components (process, indices)
class(process_t), intent(inout) :: process
integer, dimension(:), intent(in) :: indices
end subroutine process_select_components
<<Process: procedures>>=
pure module subroutine process_select_components (process, indices)
class(process_t), intent(inout) :: process
integer, dimension(:), intent(in) :: indices
associate (pcm => process%pcm)
pcm%component_selected(indices) = .true.
end associate
end subroutine process_select_components
@ %def process_select_components
@
<<Process: process: TBP>>=
procedure :: component_is_selected => process_component_is_selected
<<Process: sub interfaces>>=
pure module function process_component_is_selected &
(process, index) result (val)
logical :: val
class(process_t), intent(in) :: process
integer, intent(in) :: index
end function process_component_is_selected
<<Process: procedures>>=
pure module function process_component_is_selected &
(process, index) result (val)
logical :: val
class(process_t), intent(in) :: process
integer, intent(in) :: index
associate (pcm => process%pcm)
val = pcm%component_selected(index)
end associate
end function process_component_is_selected
@ %def process_component_is_selected
@
<<Process: process: TBP>>=
procedure :: get_coupling_powers => process_get_coupling_powers
<<Process: sub interfaces>>=
pure module subroutine process_get_coupling_powers &
(process, alpha_power, alphas_power)
class(process_t), intent(in) :: process
integer, intent(out) :: alpha_power, alphas_power
end subroutine process_get_coupling_powers
<<Process: procedures>>=
pure module subroutine process_get_coupling_powers &
(process, alpha_power, alphas_power)
class(process_t), intent(in) :: process
integer, intent(out) :: alpha_power, alphas_power
call process%component(1)%config%get_coupling_powers &
(alpha_power, alphas_power)
end subroutine process_get_coupling_powers
@ %def process_get_coupling_powers
@
<<Process: process: TBP>>=
procedure :: get_real_component => process_get_real_component
<<Process: sub interfaces>>=
module function process_get_real_component (process) result (i_real)
integer :: i_real
class(process_t), intent(in) :: process
end function process_get_real_component
<<Process: procedures>>=
module function process_get_real_component (process) result (i_real)
integer :: i_real
class(process_t), intent(in) :: process
integer :: i_component
type(process_component_def_t), pointer :: config => null ()
i_real = 0
do i_component = 1, size (process%component)
config => process%get_component_def_ptr (i_component)
if (config%get_nlo_type () == NLO_REAL) then
i_real = i_component
exit
end if
end do
end function process_get_real_component
@ %def process_get_real_component
@
<<Process: process: TBP>>=
procedure :: extract_active_component_mci => &
process_extract_active_component_mci
<<Process: sub interfaces>>=
module function process_extract_active_component_mci &
(process) result (i_active)
integer :: i_active
class(process_t), intent(in) :: process
end function process_extract_active_component_mci
<<Process: procedures>>=
module function process_extract_active_component_mci &
(process) result (i_active)
integer :: i_active
class(process_t), intent(in) :: process
integer :: i_mci, j, i_component, n_active
call count_n_active ()
if (n_active /= 1) i_active = 0
contains
subroutine count_n_active ()
n_active = 0
do i_mci = 1, size (process%mci_entry)
associate (mci_entry => process%mci_entry(i_mci))
do j = 1, size (mci_entry%i_component)
i_component = mci_entry%i_component(j)
associate (component => process%component (i_component))
if (component%can_be_integrated ()) then
i_active = i_mci
n_active = n_active + 1
end if
end associate
end do
end associate
end do
end subroutine count_n_active
end function process_extract_active_component_mci
@ %def process_extract_active_component_mci
@
<<Process: process: TBP>>=
procedure :: uses_real_partition => process_uses_real_partition
<<Process: sub interfaces>>=
module function process_uses_real_partition (process) result (val)
logical :: val
class(process_t), intent(in) :: process
end function process_uses_real_partition
<<Process: procedures>>=
module function process_uses_real_partition (process) result (val)
logical :: val
class(process_t), intent(in) :: process
val = any (process%mci_entry%real_partition_type /= REAL_FULL)
end function process_uses_real_partition
@ %def process_uses_real_partition
@ Return the MD5 sums that summarize the process component
definitions. These values should be independent of parameters, beam
details, expressions, etc. They can be used for checking the
integrity of a process when reusing an old event file.
<<Process: process: TBP>>=
procedure :: get_md5sum_prc => process_get_md5sum_prc
<<Process: sub interfaces>>=
module function process_get_md5sum_prc &
(process, i_component) result (md5sum)
character(32) :: md5sum
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
end function process_get_md5sum_prc
<<Process: procedures>>=
module function process_get_md5sum_prc (process, i_component) result (md5sum)
character(32) :: md5sum
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
if (process%component(i_component)%active) then
md5sum = process%component(i_component)%config%get_md5sum ()
else
md5sum = ""
end if
end function process_get_md5sum_prc
@ %def process_get_md5sum_prc
@ Return the MD5 sums that summarize the state of the MCI integrators.
These values should encode all process data, integration and phase
space configuration, etc., and the integration results. They can thus
be used for checking the integrity of an event-generation setup when
reusing an old event file.
<<Process: process: TBP>>=
procedure :: get_md5sum_mci => process_get_md5sum_mci
<<Process: sub interfaces>>=
module function process_get_md5sum_mci (process, i_mci) result (md5sum)
character(32) :: md5sum
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
end function process_get_md5sum_mci
<<Process: procedures>>=
module function process_get_md5sum_mci (process, i_mci) result (md5sum)
character(32) :: md5sum
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
md5sum = process%mci_entry(i_mci)%get_md5sum ()
end function process_get_md5sum_mci
@ %def process_get_md5sum_mci
@ Return the MD5 sum of the process configuration. This should encode
the process setup, data, and expressions, but no integration results.
<<Process: process: TBP>>=
procedure :: get_md5sum_cfg => process_get_md5sum_cfg
<<Process: sub interfaces>>=
module function process_get_md5sum_cfg (process) result (md5sum)
character(32) :: md5sum
class(process_t), intent(in) :: process
end function process_get_md5sum_cfg
<<Process: procedures>>=
module function process_get_md5sum_cfg (process) result (md5sum)
character(32) :: md5sum
class(process_t), intent(in) :: process
md5sum = process%config%md5sum
end function process_get_md5sum_cfg
@ %def process_get_md5sum_cfg
@
<<Process: process: TBP>>=
procedure :: get_n_cores => process_get_n_cores
<<Process: sub interfaces>>=
module function process_get_n_cores (process) result (n)
integer :: n
class(process_t), intent(in) :: process
end function process_get_n_cores
<<Process: procedures>>=
module function process_get_n_cores (process) result (n)
integer :: n
class(process_t), intent(in) :: process
n = process%pcm%n_cores
end function process_get_n_cores
@ %def process_get_n_cores
@
<<Process: process: TBP>>=
procedure :: get_base_i_term => process_get_base_i_term
<<Process: sub interfaces>>=
module function process_get_base_i_term &
(process, i_component) result (i_term)
integer :: i_term
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
end function process_get_base_i_term
<<Process: procedures>>=
module function process_get_base_i_term (process, i_component) result (i_term)
integer :: i_term
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
i_term = process%component(i_component)%i_term(1)
end function process_get_base_i_term
@ %def process_get_base_i_term
@
<<Process: process: TBP>>=
procedure :: get_core_term => process_get_core_term
<<Process: sub interfaces>>=
module function process_get_core_term (process, i_term) result (core)
class(prc_core_t), pointer :: core
class(process_t), intent(in), target :: process
integer, intent(in) :: i_term
end function process_get_core_term
<<Process: procedures>>=
module function process_get_core_term (process, i_term) result (core)
class(prc_core_t), pointer :: core
class(process_t), intent(in), target :: process
integer, intent(in) :: i_term
integer :: i_core
i_core = process%term(i_term)%i_core
core => process%core_entry(i_core)%get_core_ptr ()
end function process_get_core_term
@ %def process_get_core_term
@
<<Process: process: TBP>>=
procedure :: get_core_ptr => process_get_core_ptr
<<Process: sub interfaces>>=
module function process_get_core_ptr (process, i_core) result (core)
class(prc_core_t), pointer :: core
class(process_t), intent(in), target :: process
integer, intent(in) :: i_core
end function process_get_core_ptr
<<Process: procedures>>=
module function process_get_core_ptr (process, i_core) result (core)
class(prc_core_t), pointer :: core
class(process_t), intent(in), target :: process
integer, intent(in) :: i_core
if (allocated (process%core_entry)) then
core => process%core_entry(i_core)%get_core_ptr ()
else
core => null ()
end if
end function process_get_core_ptr
@ %def process_get_core_ptr
@
<<Process: process: TBP>>=
procedure :: get_term_ptr => process_get_term_ptr
<<Process: sub interfaces>>=
module function process_get_term_ptr (process, i) result (term)
type(process_term_t), pointer :: term
class(process_t), intent(in), target :: process
integer, intent(in) :: i
end function process_get_term_ptr
<<Process: procedures>>=
module function process_get_term_ptr (process, i) result (term)
type(process_term_t), pointer :: term
class(process_t), intent(in), target :: process
integer, intent(in) :: i
term => process%term(i)
end function process_get_term_ptr
@ %def process_get_term_ptr
@
<<Process: process: TBP>>=
procedure :: get_i_term => process_get_i_term
<<Process: sub interfaces>>=
module function process_get_i_term (process, i_core) result (i_term)
integer :: i_term
class(process_t), intent(in) :: process
integer, intent(in) :: i_core
end function process_get_i_term
<<Process: procedures>>=
module function process_get_i_term (process, i_core) result (i_term)
integer :: i_term
class(process_t), intent(in) :: process
integer, intent(in) :: i_core
do i_term = 1, process%get_n_terms ()
if (process%term(i_term)%i_core == i_core) return
end do
i_term = -1
end function process_get_i_term
@ %def process_get_i_term
@
<<Process: process: TBP>>=
procedure :: get_i_core => process_get_i_core
<<Process: sub interfaces>>=
module function process_get_i_core (process, i_term) result (i_core)
class(process_t), intent(in) :: process
integer, intent(in) :: i_term
integer :: i_core
end function process_get_i_core
<<Process: procedures>>=
module function process_get_i_core (process, i_term) result (i_core)
class(process_t), intent(in) :: process
integer, intent(in) :: i_term
integer :: i_core
i_core = process%term(i_term)%i_core
end function process_get_i_core
@ %def process_get_i_core
@
<<Process: process: TBP>>=
procedure :: set_i_mci_work => process_set_i_mci_work
<<Process: sub interfaces>>=
module subroutine process_set_i_mci_work (process, i_mci)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
end subroutine process_set_i_mci_work
<<Process: procedures>>=
module subroutine process_set_i_mci_work (process, i_mci)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
process%mci_entry(i_mci)%i_mci = i_mci
end subroutine process_set_i_mci_work
@ %def process_set_i_mci_work
@
<<Process: process: TBP>>=
procedure :: get_i_mci_work => process_get_i_mci_work
<<Process: sub interfaces>>=
pure module function process_get_i_mci_work &
(process, i_mci) result (i_mci_work)
integer :: i_mci_work
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
end function process_get_i_mci_work
<<Process: procedures>>=
pure module function process_get_i_mci_work &
(process, i_mci) result (i_mci_work)
integer :: i_mci_work
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
i_mci_work = process%mci_entry(i_mci)%i_mci
end function process_get_i_mci_work
@ %def process_get_i_mci_work
@
<<Process: process: TBP>>=
procedure :: get_i_sub => process_get_i_sub
<<Process: sub interfaces>>=
elemental module function process_get_i_sub (process, i_term) result (i_sub)
integer :: i_sub
class(process_t), intent(in) :: process
integer, intent(in) :: i_term
end function process_get_i_sub
<<Process: procedures>>=
elemental module function process_get_i_sub (process, i_term) result (i_sub)
integer :: i_sub
class(process_t), intent(in) :: process
integer, intent(in) :: i_term
i_sub = process%term(i_term)%i_sub
end function process_get_i_sub
@ %def process_get_i_sub
@
<<Process: process: TBP>>=
procedure :: get_i_term_virtual => process_get_i_term_virtual
<<Process: sub interfaces>>=
elemental module function process_get_i_term_virtual &
(process) result (i_term)
integer :: i_term
class(process_t), intent(in) :: process
end function process_get_i_term_virtual
<<Process: procedures>>=
elemental module function process_get_i_term_virtual (process) result (i_term)
integer :: i_term
class(process_t), intent(in) :: process
integer :: i_component
i_term = 0
do i_component = 1, size (process%component)
if (process%component(i_component)%get_nlo_type () == NLO_VIRTUAL) &
i_term = process%component(i_component)%i_term(1)
end do
end function process_get_i_term_virtual
@ %def process_get_i_term_virtual
@
<<Process: process: TBP>>=
generic :: component_is_active => component_is_active_single
procedure :: component_is_active_single => process_component_is_active_single
<<Process: sub interfaces>>=
elemental module function process_component_is_active_single &
(process, i_comp) result (val)
logical :: val
class(process_t), intent(in) :: process
integer, intent(in) :: i_comp
end function process_component_is_active_single
<<Process: procedures>>=
elemental module function process_component_is_active_single &
(process, i_comp) result (val)
logical :: val
class(process_t), intent(in) :: process
integer, intent(in) :: i_comp
val = process%component(i_comp)%is_active ()
end function process_component_is_active_single
@ %def process_component_is_active_single
@
<<Process: process: TBP>>=
generic :: component_is_active => component_is_active_all
procedure :: component_is_active_all => process_component_is_active_all
<<Process: sub interfaces>>=
pure module function process_component_is_active_all (process) result (val)
logical, dimension(:), allocatable :: val
class(process_t), intent(in) :: process
end function process_component_is_active_all
<<Process: procedures>>=
pure module function process_component_is_active_all (process) result (val)
logical, dimension(:), allocatable :: val
class(process_t), intent(in) :: process
allocate (val (size (process%component)))
val = process%component%is_active ()
end function process_component_is_active_all
@ %def process_component_is_active_all
@
\subsection{Default iterations}
If the user does not specify the passes and iterations for
integration, we should be able to give reasonable defaults. These
depend on the process, therefore we implement the following procedures
as methods of the process object. The algorithm is not very
sophisticated yet, it may be improved by looking at the process in
more detail.
We investigate only the first process component, assuming that it
characterizes the complexity of the process reasonable well.
The number of passes is limited to two: one for adaption, one for
integration.
<<Process: process: TBP>>=
procedure :: get_n_pass_default => process_get_n_pass_default
procedure :: adapt_grids_default => process_adapt_grids_default
procedure :: adapt_weights_default => process_adapt_weights_default
<<Process: sub interfaces>>=
module function process_get_n_pass_default (process) result (n_pass)
class(process_t), intent(in) :: process
integer :: n_pass
end function process_get_n_pass_default
module function process_adapt_grids_default (process, pass) result (flag)
class(process_t), intent(in) :: process
integer, intent(in) :: pass
logical :: flag
end function process_adapt_grids_default
module function process_adapt_weights_default (process, pass) result (flag)
class(process_t), intent(in) :: process
integer, intent(in) :: pass
logical :: flag
end function process_adapt_weights_default
<<Process: procedures>>=
module function process_get_n_pass_default (process) result (n_pass)
class(process_t), intent(in) :: process
integer :: n_pass
integer :: n_eff
type(process_component_def_t), pointer :: config
config => process%component(1)%config
n_eff = config%get_n_tot () - 2
select case (n_eff)
case (1)
n_pass = 1
case default
n_pass = 2
end select
end function process_get_n_pass_default
module function process_adapt_grids_default (process, pass) result (flag)
class(process_t), intent(in) :: process
integer, intent(in) :: pass
logical :: flag
integer :: n_eff
type(process_component_def_t), pointer :: config
config => process%component(1)%config
n_eff = config%get_n_tot () - 2
select case (n_eff)
case (1)
flag = .false.
case default
select case (pass)
case (1); flag = .true.
case (2); flag = .false.
case default
call msg_bug ("adapt grids default: impossible pass index")
end select
end select
end function process_adapt_grids_default
module function process_adapt_weights_default (process, pass) result (flag)
class(process_t), intent(in) :: process
integer, intent(in) :: pass
logical :: flag
integer :: n_eff
type(process_component_def_t), pointer :: config
config => process%component(1)%config
n_eff = config%get_n_tot () - 2
select case (n_eff)
case (1)
flag = .false.
case default
select case (pass)
case (1); flag = .true.
case (2); flag = .false.
case default
call msg_bug ("adapt weights default: impossible pass index")
end select
end select
end function process_adapt_weights_default
@ %def process_get_n_pass_default
@ %def process_adapt_grids_default
@ %def process_adapt_weights_default
@ The number of iterations and calls per iteration depends on the
number of outgoing particles.
<<Process: process: TBP>>=
procedure :: get_n_it_default => process_get_n_it_default
procedure :: get_n_calls_default => process_get_n_calls_default
<<Process: sub interfaces>>=
module function process_get_n_it_default (process, pass) result (n_it)
class(process_t), intent(in) :: process
integer, intent(in) :: pass
integer :: n_it
end function process_get_n_it_default
module function process_get_n_calls_default (process, pass) result (n_calls)
class(process_t), intent(in) :: process
integer, intent(in) :: pass
integer :: n_calls
end function process_get_n_calls_default
<<Process: procedures>>=
module function process_get_n_it_default (process, pass) result (n_it)
class(process_t), intent(in) :: process
integer, intent(in) :: pass
integer :: n_it
integer :: n_eff
type(process_component_def_t), pointer :: config
config => process%component(1)%config
n_eff = config%get_n_tot () - 2
select case (pass)
case (1)
select case (n_eff)
case (1); n_it = 1
case (2); n_it = 3
case (3); n_it = 5
case (4:5); n_it = 10
case (6); n_it = 15
case (7:); n_it = 20
end select
case (2)
select case (n_eff)
case (:3); n_it = 3
case (4:); n_it = 5
end select
end select
end function process_get_n_it_default
module function process_get_n_calls_default (process, pass) result (n_calls)
class(process_t), intent(in) :: process
integer, intent(in) :: pass
integer :: n_calls
integer :: n_eff
type(process_component_def_t), pointer :: config
config => process%component(1)%config
n_eff = config%get_n_tot () - 2
select case (pass)
case (1)
select case (n_eff)
case (1); n_calls = 100
case (2); n_calls = 1000
case (3); n_calls = 5000
case (4); n_calls = 10000
case (5); n_calls = 20000
case (6:); n_calls = 50000
end select
case (2)
select case (n_eff)
case (:3); n_calls = 10000
case (4); n_calls = 20000
case (5); n_calls = 50000
case (6); n_calls = 100000
case (7:); n_calls = 200000
end select
end select
end function process_get_n_calls_default
@ %def process_get_n_it_default
@ %def process_get_n_calls_default
@
\subsection{Constant process data}
Manually set the Run ID (unit test only).
<<Process: process: TBP>>=
procedure :: set_run_id => process_set_run_id
<<Process: sub interfaces>>=
module subroutine process_set_run_id (process, run_id)
class(process_t), intent(inout) :: process
type(string_t), intent(in) :: run_id
end subroutine process_set_run_id
<<Process: procedures>>=
module subroutine process_set_run_id (process, run_id)
class(process_t), intent(inout) :: process
type(string_t), intent(in) :: run_id
process%meta%run_id = run_id
end subroutine process_set_run_id
@ %def process_set_run_id
@
The following methods return basic process data that stay constant
after initialization.
The process and IDs.
<<Process: process: TBP>>=
procedure :: get_id => process_get_id
procedure :: get_num_id => process_get_num_id
procedure :: get_run_id => process_get_run_id
procedure :: get_library_name => process_get_library_name
<<Process: sub interfaces>>=
module function process_get_id (process) result (id)
class(process_t), intent(in) :: process
type(string_t) :: id
end function process_get_id
module function process_get_num_id (process) result (id)
class(process_t), intent(in) :: process
integer :: id
end function process_get_num_id
module function process_get_run_id (process) result (id)
class(process_t), intent(in) :: process
type(string_t) :: id
end function process_get_run_id
module function process_get_library_name (process) result (id)
class(process_t), intent(in) :: process
type(string_t) :: id
end function process_get_library_name
<<Process: procedures>>=
module function process_get_id (process) result (id)
class(process_t), intent(in) :: process
type(string_t) :: id
id = process%meta%id
end function process_get_id
module function process_get_num_id (process) result (id)
class(process_t), intent(in) :: process
integer :: id
id = process%meta%num_id
end function process_get_num_id
module function process_get_run_id (process) result (id)
class(process_t), intent(in) :: process
type(string_t) :: id
id = process%meta%run_id
end function process_get_run_id
module function process_get_library_name (process) result (id)
class(process_t), intent(in) :: process
type(string_t) :: id
id = process%meta%lib_name
end function process_get_library_name
@ %def process_get_id process_get_num_id
@ %def process_get_run_id process_get_library_name
@ The number of incoming particles.
<<Process: process: TBP>>=
procedure :: get_n_in => process_get_n_in
<<Process: sub interfaces>>=
module function process_get_n_in (process) result (n)
class(process_t), intent(in) :: process
integer :: n
end function process_get_n_in
<<Process: procedures>>=
module function process_get_n_in (process) result (n)
class(process_t), intent(in) :: process
integer :: n
n = process%config%n_in
end function process_get_n_in
@ %def process_get_n_in
@ The number of MCI data sets.
<<Process: process: TBP>>=
procedure :: get_n_mci => process_get_n_mci
<<Process: sub interfaces>>=
module function process_get_n_mci (process) result (n)
class(process_t), intent(in) :: process
integer :: n
end function process_get_n_mci
<<Process: procedures>>=
module function process_get_n_mci (process) result (n)
class(process_t), intent(in) :: process
integer :: n
n = process%config%n_mci
end function process_get_n_mci
@ %def process_get_n_mci
@ The number of process components, total.
<<Process: process: TBP>>=
procedure :: get_n_components => process_get_n_components
<<Process: sub interfaces>>=
module function process_get_n_components (process) result (n)
class(process_t), intent(in) :: process
integer :: n
end function process_get_n_components
<<Process: procedures>>=
module function process_get_n_components (process) result (n)
class(process_t), intent(in) :: process
integer :: n
n = process%meta%n_components
end function process_get_n_components
@ %def process_get_n_components
@ The number of process terms, total.
<<Process: process: TBP>>=
procedure :: get_n_terms => process_get_n_terms
<<Process: sub interfaces>>=
module function process_get_n_terms (process) result (n)
class(process_t), intent(in) :: process
integer :: n
end function process_get_n_terms
<<Process: procedures>>=
module function process_get_n_terms (process) result (n)
class(process_t), intent(in) :: process
integer :: n
n = process%config%n_terms
end function process_get_n_terms
@ %def process_get_n_terms
@ Return the indices of the components that belong to a
specific MCI entry.
<<Process: process: TBP>>=
procedure :: get_i_component => process_get_i_component
<<Process: sub interfaces>>=
module subroutine process_get_i_component (process, i_mci, i_component)
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
integer, dimension(:), intent(out), allocatable :: i_component
end subroutine process_get_i_component
<<Process: procedures>>=
module subroutine process_get_i_component (process, i_mci, i_component)
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
integer, dimension(:), intent(out), allocatable :: i_component
associate (mci_entry => process%mci_entry(i_mci))
allocate (i_component (size (mci_entry%i_component)))
i_component = mci_entry%i_component
end associate
end subroutine process_get_i_component
@ %def process_get_i_component
@ Return the ID of a specific component.
<<Process: process: TBP>>=
procedure :: get_component_id => process_get_component_id
<<Process: sub interfaces>>=
module function process_get_component_id (process, i_component) result (id)
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
type(string_t) :: id
end function process_get_component_id
<<Process: procedures>>=
module function process_get_component_id (process, i_component) result (id)
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
type(string_t) :: id
id = process%meta%component_id(i_component)
end function process_get_component_id
@ %def process_get_component_id
@ Return a pointer to the definition of a specific component.
<<Process: process: TBP>>=
procedure :: get_component_def_ptr => process_get_component_def_ptr
<<Process: sub interfaces>>=
module function process_get_component_def_ptr &
(process, i_component) result (ptr)
type(process_component_def_t), pointer :: ptr
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
end function process_get_component_def_ptr
<<Process: procedures>>=
module function process_get_component_def_ptr &
(process, i_component) result (ptr)
type(process_component_def_t), pointer :: ptr
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
ptr => process%config%process_def%get_component_def_ptr (i_component)
end function process_get_component_def_ptr
@ %def process_get_component_def_ptr
@ These procedures extract and restore (by transferring the
allocation) the process core. This is useful for changing process
parameters from outside this module.
<<Process: process: TBP>>=
procedure :: extract_core => process_extract_core
procedure :: restore_core => process_restore_core
<<Process: sub interfaces>>=
module subroutine process_extract_core (process, i_term, core)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_term
class(prc_core_t), intent(inout), allocatable :: core
end subroutine process_extract_core
module subroutine process_restore_core (process, i_term, core)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_term
class(prc_core_t), intent(inout), allocatable :: core
end subroutine process_restore_core
<<Process: procedures>>=
module subroutine process_extract_core (process, i_term, core)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_term
class(prc_core_t), intent(inout), allocatable :: core
integer :: i_core
i_core = process%term(i_term)%i_core
call move_alloc (from = process%core_entry(i_core)%core, to = core)
end subroutine process_extract_core
module subroutine process_restore_core (process, i_term, core)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_term
class(prc_core_t), intent(inout), allocatable :: core
integer :: i_core
i_core = process%term(i_term)%i_core
call move_alloc (from = core, to = process%core_entry(i_core)%core)
end subroutine process_restore_core
@ %def process_extract_core
@ %def process_restore_core
@ The block of process constants.
<<Process: process: TBP>>=
procedure :: get_constants => process_get_constants
<<Process: sub interfaces>>=
module function process_get_constants (process, i_core) result (data)
type(process_constants_t) :: data
class(process_t), intent(in) :: process
integer, intent(in) :: i_core
end function process_get_constants
<<Process: procedures>>=
module function process_get_constants (process, i_core) result (data)
type(process_constants_t) :: data
class(process_t), intent(in) :: process
integer, intent(in) :: i_core
data = process%core_entry(i_core)%core%data
end function process_get_constants
@ %def process_get_constants
@
<<Process: process: TBP>>=
procedure :: get_config => process_get_config
<<Process: sub interfaces>>=
module function process_get_config (process) result (config)
type(process_config_data_t) :: config
class(process_t), intent(in) :: process
end function process_get_config
<<Process: procedures>>=
module function process_get_config (process) result (config)
type(process_config_data_t) :: config
class(process_t), intent(in) :: process
config = process%config
end function process_get_config
@ %def process_get_config
@
Construct an MD5 sum for the constant data, including the NLO type.
For the NLO type [[NLO_MISMATCH]], we pretend that this was
[[NLO_SUBTRACTION]] instead.
TODO wk 2018: should not depend explicitly on NLO data.
<<Process: process: TBP>>=
procedure :: get_md5sum_constants => process_get_md5sum_constants
<<Process: sub interfaces>>=
module function process_get_md5sum_constants (process, i_component, &
type_string, nlo_type) result (this_md5sum)
character(32) :: this_md5sum
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
type(string_t), intent(in) :: type_string
integer, intent(in) :: nlo_type
end function process_get_md5sum_constants
<<Process: procedures>>=
module function process_get_md5sum_constants (process, i_component, &
type_string, nlo_type) result (this_md5sum)
character(32) :: this_md5sum
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
type(string_t), intent(in) :: type_string
integer, intent(in) :: nlo_type
type(process_constants_t) :: data
integer :: unit
call process%env%fill_process_constants (process%meta%id, i_component, data)
unit = data%fill_unit_for_md5sum (.false.)
write (unit, '(A)') char(type_string)
select case (nlo_type)
case (NLO_MISMATCH)
write (unit, '(I0)') NLO_SUBTRACTION
case default
write (unit, '(I0)') nlo_type
end select
rewind (unit)
this_md5sum = md5sum (unit)
close (unit)
end function process_get_md5sum_constants
@ %def process_get_md5sum_constants
@ Return the set of outgoing flavors that are associated with a particular
term. We deduce this from the effective interaction.
<<Process: process: TBP>>=
procedure :: get_term_flv_out => process_get_term_flv_out
<<Process: sub interfaces>>=
module subroutine process_get_term_flv_out (process, i_term, flv)
class(process_t), intent(in), target :: process
integer, intent(in) :: i_term
type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv
end subroutine process_get_term_flv_out
<<Process: procedures>>=
module subroutine process_get_term_flv_out (process, i_term, flv)
class(process_t), intent(in), target :: process
integer, intent(in) :: i_term
type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv
type(interaction_t), pointer :: int
int => process%term(i_term)%int_eff
if (.not. associated (int)) int => process%term(i_term)%int
call int%get_flv_out (flv)
end subroutine process_get_term_flv_out
@ %def process_get_term_flv_out
@ Return true if there is any unstable particle in any of the process
terms. We decide this based on the provided model instance, not the
one that is stored in the process object.
<<Process: process: TBP>>=
procedure :: contains_unstable => process_contains_unstable
<<Process: sub interfaces>>=
module function process_contains_unstable (process, model) result (flag)
class(process_t), intent(in) :: process
class(model_data_t), intent(in), target :: model
logical :: flag
end function process_contains_unstable
<<Process: procedures>>=
module function process_contains_unstable (process, model) result (flag)
class(process_t), intent(in) :: process
class(model_data_t), intent(in), target :: model
logical :: flag
integer :: i_term
type(flavor_t), dimension(:,:), allocatable :: flv
flag = .false.
do i_term = 1, process%get_n_terms ()
call process%get_term_flv_out (i_term, flv)
call flv%set_model (model)
flag = .not. all (flv%is_stable ())
deallocate (flv)
if (flag) return
end do
end function process_contains_unstable
@ %def process_contains_unstable
@ The nominal process energy.
<<Process: process: TBP>>=
procedure :: get_sqrts => process_get_sqrts
<<Process: sub interfaces>>=
module function process_get_sqrts (process) result (sqrts)
class(process_t), intent(in) :: process
real(default) :: sqrts
end function process_get_sqrts
<<Process: procedures>>=
module function process_get_sqrts (process) result (sqrts)
class(process_t), intent(in) :: process
real(default) :: sqrts
sqrts = process%beam_config%data%get_sqrts ()
end function process_get_sqrts
@ %def process_get_sqrts
@ The lab-frame beam energy/energies..
<<Process: process: TBP>>=
procedure :: get_energy => process_get_energy
<<Process: sub interfaces>>=
module function process_get_energy (process) result (e)
class(process_t), intent(in) :: process
real(default), dimension(:), allocatable :: e
end function process_get_energy
<<Process: procedures>>=
module function process_get_energy (process) result (e)
class(process_t), intent(in) :: process
real(default), dimension(:), allocatable :: e
e = process%beam_config%data%get_energy ()
end function process_get_energy
@ %def process_get_energy
@ The beam polarization in case of simple degrees.
<<Process: process: TBP>>=
procedure :: get_polarization => process_get_polarization
<<Process: sub interfaces>>=
module function process_get_polarization (process) result (pol)
class(process_t), intent(in) :: process
real(default), dimension(process%beam_config%data%n) :: pol
end function process_get_polarization
<<Process: procedures>>=
module function process_get_polarization (process) result (pol)
class(process_t), intent(in) :: process
real(default), dimension(process%beam_config%data%n) :: pol
pol = process%beam_config%data%get_polarization ()
end function process_get_polarization
@ %def process_get_polarization
@
<<Process: process: TBP>>=
procedure :: get_meta => process_get_meta
<<Process: sub interfaces>>=
module function process_get_meta (process) result (meta)
type(process_metadata_t) :: meta
class(process_t), intent(in) :: process
end function process_get_meta
<<Process: procedures>>=
module function process_get_meta (process) result (meta)
type(process_metadata_t) :: meta
class(process_t), intent(in) :: process
meta = process%meta
end function process_get_meta
@ %def process_get_meta
<<Process: process: TBP>>=
procedure :: has_matrix_element => process_has_matrix_element
<<Process: sub interfaces>>=
module function process_has_matrix_element &
(process, i, is_term_index) result (active)
logical :: active
class(process_t), intent(in) :: process
integer, intent(in), optional :: i
logical, intent(in), optional :: is_term_index
end function process_has_matrix_element
<<Process: procedures>>=
module function process_has_matrix_element &
(process, i, is_term_index) result (active)
logical :: active
class(process_t), intent(in) :: process
integer, intent(in), optional :: i
logical, intent(in), optional :: is_term_index
integer :: i_component
logical :: is_term
is_term = .false.
if (present (i)) then
if (present (is_term_index)) is_term = is_term_index
if (is_term) then
i_component = process%term(i)%i_component
else
i_component = i
end if
active = process%component(i_component)%active
else
active = any (process%component%active)
end if
end function process_has_matrix_element
@ %def process_has_matrix_element
@ Pointer to the beam data object.
<<Process: process: TBP>>=
procedure :: get_beam_data_ptr => process_get_beam_data_ptr
<<Process: sub interfaces>>=
module function process_get_beam_data_ptr (process) result (beam_data)
class(process_t), intent(in), target :: process
type(beam_data_t), pointer :: beam_data
end function process_get_beam_data_ptr
<<Process: procedures>>=
module function process_get_beam_data_ptr (process) result (beam_data)
class(process_t), intent(in), target :: process
type(beam_data_t), pointer :: beam_data
beam_data => process%beam_config%data
end function process_get_beam_data_ptr
@ %def process_get_beam_data_ptr
@
<<Process: process: TBP>>=
procedure :: get_beam_config => process_get_beam_config
<<Process: sub interfaces>>=
module function process_get_beam_config (process) result (beam_config)
type(process_beam_config_t) :: beam_config
class(process_t), intent(in) :: process
end function process_get_beam_config
<<Process: procedures>>=
module function process_get_beam_config (process) result (beam_config)
type(process_beam_config_t) :: beam_config
class(process_t), intent(in) :: process
beam_config = process%beam_config
end function process_get_beam_config
@ %def process_get_beam_config
@
<<Process: process: TBP>>=
procedure :: get_beam_config_ptr => process_get_beam_config_ptr
<<Process: sub interfaces>>=
module function process_get_beam_config_ptr (process) result (beam_config)
type(process_beam_config_t), pointer :: beam_config
class(process_t), intent(in), target :: process
end function process_get_beam_config_ptr
<<Process: procedures>>=
module function process_get_beam_config_ptr (process) result (beam_config)
type(process_beam_config_t), pointer :: beam_config
class(process_t), intent(in), target :: process
beam_config => process%beam_config
end function process_get_beam_config_ptr
@ %def process_get_beam_config_ptr
@ Get the PDF set currently in use, if any.
<<Process: process: TBP>>=
procedure :: get_pdf_set => process_get_pdf_set
<<Process: sub interfaces>>=
module function process_get_pdf_set (process) result (pdf_set)
class(process_t), intent(in) :: process
integer :: pdf_set
end function process_get_pdf_set
<<Process: procedures>>=
module function process_get_pdf_set (process) result (pdf_set)
class(process_t), intent(in) :: process
integer :: pdf_set
pdf_set = process%beam_config%get_pdf_set ()
end function process_get_pdf_set
@ %def process_get_pdf_set
@
<<Process: process: TBP>>=
procedure :: pcm_contains_pdfs => process_pcm_contains_pdfs
<<Process: sub interfaces>>=
module function process_pcm_contains_pdfs (process) result (has_pdfs)
logical :: has_pdfs
class(process_t), intent(in) :: process
end function process_pcm_contains_pdfs
<<Process: procedures>>=
module function process_pcm_contains_pdfs (process) result (has_pdfs)
logical :: has_pdfs
class(process_t), intent(in) :: process
has_pdfs = process%pcm%has_pdfs
end function process_pcm_contains_pdfs
@ %def process_pcm_contains_pdfs
@ Get the beam spectrum file currently in use, if any.
<<Process: process: TBP>>=
procedure :: get_beam_file => process_get_beam_file
<<Process: sub interfaces>>=
module function process_get_beam_file (process) result (file)
class(process_t), intent(in) :: process
type(string_t) :: file
end function process_get_beam_file
<<Process: procedures>>=
module function process_get_beam_file (process) result (file)
class(process_t), intent(in) :: process
type(string_t) :: file
file = process%beam_config%get_beam_file ()
end function process_get_beam_file
@ %def process_get_beam_file
@ Pointer to the process variable list.
<<Process: process: TBP>>=
procedure :: get_var_list_ptr => process_get_var_list_ptr
<<Process: sub interfaces>>=
module function process_get_var_list_ptr (process) result (ptr)
class(process_t), intent(in), target :: process
type(var_list_t), pointer :: ptr
end function process_get_var_list_ptr
<<Process: procedures>>=
module function process_get_var_list_ptr (process) result (ptr)
class(process_t), intent(in), target :: process
type(var_list_t), pointer :: ptr
ptr => process%env%get_var_list_ptr ()
end function process_get_var_list_ptr
@ %def process_get_var_list_ptr
@ Pointer to the common model.
<<Process: process: TBP>>=
procedure :: get_model_ptr => process_get_model_ptr
<<Process: sub interfaces>>=
module function process_get_model_ptr (process) result (ptr)
class(process_t), intent(in) :: process
class(model_data_t), pointer :: ptr
end function process_get_model_ptr
<<Process: procedures>>=
module function process_get_model_ptr (process) result (ptr)
class(process_t), intent(in) :: process
class(model_data_t), pointer :: ptr
ptr => process%config%model
end function process_get_model_ptr
@ %def process_get_model_ptr
@ Use the embedded RNG factory to spawn a new random-number generator
instance. (This modifies the state of the factory.)
<<Process: process: TBP>>=
procedure :: make_rng => process_make_rng
<<Process: sub interfaces>>=
module subroutine process_make_rng (process, rng)
class(process_t), intent(inout) :: process
class(rng_t), intent(out), allocatable :: rng
end subroutine process_make_rng
<<Process: procedures>>=
module subroutine process_make_rng (process, rng)
class(process_t), intent(inout) :: process
class(rng_t), intent(out), allocatable :: rng
if (allocated (process%rng_factory)) then
call process%rng_factory%make (rng)
else
call msg_bug ("Process: make rng: factory not allocated")
end if
end subroutine process_make_rng
@ %def process_make_rng
@
\subsection{Compute an amplitude}
Each process variant should allow for computing an amplitude value
directly, without generating a process instance.
The process component is selected by the index [[i]]. The term within the
process component is selected by [[j]]. The momentum
combination is transferred as the array [[p]]. The function sets the specific
quantum state via the indices of a flavor [[f]], helicity [[h]], and color
[[c]] combination. Each index refers to the list of flavor, helicity, and
color states, respectively, as stored in the process data.
Optionally, we may set factorization and renormalization scale. If unset, the
partonic c.m.\ energy is inserted.
The function checks arguments for validity.
For invalid arguments (quantum states), we return zero.
<<Process: process: TBP>>=
procedure :: compute_amplitude => process_compute_amplitude
<<Process: sub interfaces>>=
module function process_compute_amplitude (process, i_core, i, j, p, &
f, h, c, fac_scale, ren_scale, alpha_qcd_forced) result (amp)
class(process_t), intent(in), target :: process
integer, intent(in) :: i_core
integer, intent(in) :: i, j
type(vector4_t), dimension(:), intent(in) :: p
integer, intent(in) :: f, h, c
real(default), intent(in), optional :: fac_scale, ren_scale
real(default), intent(in), allocatable, optional :: alpha_qcd_forced
complex(default) :: amp
end function process_compute_amplitude
<<Process: procedures>>=
module function process_compute_amplitude (process, i_core, i, j, p, &
f, h, c, fac_scale, ren_scale, alpha_qcd_forced) result (amp)
class(process_t), intent(in), target :: process
integer, intent(in) :: i_core
integer, intent(in) :: i, j
type(vector4_t), dimension(:), intent(in) :: p
integer, intent(in) :: f, h, c
real(default), intent(in), optional :: fac_scale, ren_scale
real(default), intent(in), allocatable, optional :: alpha_qcd_forced
real(default) :: fscale, rscale
real(default), allocatable :: aqcd_forced
complex(default) :: amp
class(prc_core_t), pointer :: core
amp = 0
if (0 < i .and. i <= process%meta%n_components) then
if (process%component(i)%active) then
associate (core => process%core_entry(i_core)%core)
associate (data => core%data)
if (size (p) == data%n_in + data%n_out &
.and. 0 < f .and. f <= data%n_flv &
.and. 0 < h .and. h <= data%n_hel &
.and. 0 < c .and. c <= data%n_col) then
if (present (fac_scale)) then
fscale = fac_scale
else
fscale = sum (p(data%n_in+1:)) ** 1
end if
if (present (ren_scale)) then
rscale = ren_scale
else
rscale = fscale
end if
if (present (alpha_qcd_forced)) then
if (allocated (alpha_qcd_forced)) &
allocate (aqcd_forced, source = alpha_qcd_forced)
end if
amp = core%compute_amplitude (j, p, f, h, c, &
fscale, rscale, aqcd_forced)
end if
end associate
end associate
else
amp = 0
end if
end if
end function process_compute_amplitude
@ %def process_compute_amplitude
@ Sanity check for the process library. We abort the program if it
has changed after process initialization.
<<Process: process: TBP>>=
procedure :: check_library_sanity => process_check_library_sanity
<<Process: sub interfaces>>=
module subroutine process_check_library_sanity (process)
class(process_t), intent(in) :: process
end subroutine process_check_library_sanity
<<Process: procedures>>=
module subroutine process_check_library_sanity (process)
class(process_t), intent(in) :: process
call process%env%check_lib_sanity (process%meta)
end subroutine process_check_library_sanity
@ %def process_check_library_sanity
@ Reset the association to a process library.
<<Process: process: TBP>>=
procedure :: reset_library_ptr => process_reset_library_ptr
<<Process: sub interfaces>>=
module subroutine process_reset_library_ptr (process)
class(process_t), intent(inout) :: process
end subroutine process_reset_library_ptr
<<Process: procedures>>=
module subroutine process_reset_library_ptr (process)
class(process_t), intent(inout) :: process
call process%env%reset_lib_ptr ()
end subroutine process_reset_library_ptr
@ %def process_reset_library_ptr
@
<<Process: process: TBP>>=
procedure :: set_counter_mci_entry => process_set_counter_mci_entry
<<Process: sub interfaces>>=
module subroutine process_set_counter_mci_entry (process, i_mci, counter)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
type(process_counter_t), intent(in) :: counter
end subroutine process_set_counter_mci_entry
<<Process: procedures>>=
module subroutine process_set_counter_mci_entry (process, i_mci, counter)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
type(process_counter_t), intent(in) :: counter
process%mci_entry(i_mci)%counter = counter
end subroutine process_set_counter_mci_entry
@ %def process_set_counter_mci_entry
@ This is for suppression of numerical noise in the integration results
stored in the [[process_mci_entry]] type. As the error and efficiency
enter the MD5 sum, we recompute it.
<<Process: process: TBP>>=
procedure :: pacify => process_pacify
<<Process: sub interfaces>>=
module subroutine process_pacify (process, efficiency_reset, error_reset)
class(process_t), intent(inout) :: process
logical, intent(in), optional :: efficiency_reset, error_reset
end subroutine process_pacify
<<Process: procedures>>=
module subroutine process_pacify (process, efficiency_reset, error_reset)
class(process_t), intent(inout) :: process
logical, intent(in), optional :: efficiency_reset, error_reset
logical :: eff_reset, err_reset
integer :: i
eff_reset = .false.
err_reset = .false.
if (present (efficiency_reset)) eff_reset = efficiency_reset
if (present (error_reset)) err_reset = error_reset
if (allocated (process%mci_entry)) then
do i = 1, size (process%mci_entry)
call process%mci_entry(i)%results%pacify (efficiency_reset)
if (allocated (process%mci_entry(i)%mci)) then
associate (mci => process%mci_entry(i)%mci)
if (process%mci_entry(i)%mci%error_known &
.and. err_reset) &
mci%error = 0
if (process%mci_entry(i)%mci%efficiency_known &
.and. eff_reset) &
mci%efficiency = 1
call mci%pacify (efficiency_reset, error_reset)
call mci%compute_md5sum ()
end associate
end if
end do
end if
end subroutine process_pacify
@ %def process_pacify
@ The following methods are used only in the unit tests; the access
process internals directly that would otherwise be hidden.
<<Process: process: TBP>>=
procedure :: test_allocate_sf_channels
procedure :: test_set_component_sf_channel
procedure :: test_get_mci_ptr
<<Process: sub interfaces>>=
module subroutine test_allocate_sf_channels (process, n)
class(process_t), intent(inout) :: process
integer, intent(in) :: n
end subroutine test_allocate_sf_channels
module subroutine test_set_component_sf_channel (process, c)
class(process_t), intent(inout) :: process
integer, dimension(:), intent(in) :: c
end subroutine test_set_component_sf_channel
module subroutine test_get_mci_ptr (process, mci)
class(process_t), intent(in), target :: process
class(mci_t), intent(out), pointer :: mci
end subroutine test_get_mci_ptr
<<Process: procedures>>=
module subroutine test_allocate_sf_channels (process, n)
class(process_t), intent(inout) :: process
integer, intent(in) :: n
call process%beam_config%allocate_sf_channels (n)
end subroutine test_allocate_sf_channels
module subroutine test_set_component_sf_channel (process, c)
class(process_t), intent(inout) :: process
integer, dimension(:), intent(in) :: c
call process%component(1)%phs_config%set_sf_channel (c)
end subroutine test_set_component_sf_channel
module subroutine test_get_mci_ptr (process, mci)
class(process_t), intent(in), target :: process
class(mci_t), intent(out), pointer :: mci
mci => process%mci_entry(1)%mci
end subroutine test_get_mci_ptr
@ %def test_allocate_sf_channels
@ %def test_set_component_sf_channel
@ %def test_get_mci_ptr
@
<<Process: process: TBP>>=
procedure :: init_mci_work => process_init_mci_work
<<Process: sub interfaces>>=
module subroutine process_init_mci_work (process, mci_work, i)
class(process_t), intent(in), target :: process
type(mci_work_t), intent(out) :: mci_work
integer, intent(in) :: i
end subroutine process_init_mci_work
<<Process: procedures>>=
module subroutine process_init_mci_work (process, mci_work, i)
class(process_t), intent(in), target :: process
type(mci_work_t), intent(out) :: mci_work
integer, intent(in) :: i
call mci_work%init (process%mci_entry(i))
end subroutine process_init_mci_work
@ %def process_init_mci_work
@
Prepare the process core with type [[test_me]], or otherwise the externally
provided [[type_string]] version. The toy dispatchers as a procedure
argument come handy, knowing that we need to support only the [[test_me]] and
[[template]] matrix-element types.
Gfortran 7/8/9 bug, has to remain in the main module:
<<Process: process: TBP>>=
procedure :: setup_test_cores => process_setup_test_cores
<<Process: main procedures>>=
subroutine dispatch_test_me_core (core, core_def, model, &
helicity_selection, qcd, use_color_factors, has_beam_pol)
use prc_test_core, only: test_t
class(prc_core_t), allocatable, intent(inout) :: core
class(prc_core_def_t), intent(in) :: core_def
class(model_data_t), intent(in), target, optional :: model
type(helicity_selection_t), intent(in), optional :: helicity_selection
type(qcd_t), intent(in), optional :: qcd
logical, intent(in), optional :: use_color_factors
logical, intent(in), optional :: has_beam_pol
allocate (test_t :: core)
end subroutine dispatch_test_me_core
subroutine dispatch_template_core (core, core_def, model, &
helicity_selection, qcd, use_color_factors, has_beam_pol)
use prc_template_me, only: prc_template_me_t
class(prc_core_t), allocatable, intent(inout) :: core
class(prc_core_def_t), intent(in) :: core_def
class(model_data_t), intent(in), target, optional :: model
type(helicity_selection_t), intent(in), optional :: helicity_selection
type(qcd_t), intent(in), optional :: qcd
logical, intent(in), optional :: use_color_factors
logical, intent(in), optional :: has_beam_pol
allocate (prc_template_me_t :: core)
select type (core)
type is (prc_template_me_t)
call core%set_parameters (model)
end select
end subroutine dispatch_template_core
subroutine process_setup_test_cores (process, type_string)
class(process_t), intent(inout) :: process
class(prc_core_t), allocatable :: core
type(string_t), intent(in), optional :: type_string
if (present (type_string)) then
select case (char (type_string))
case ("template")
call process%setup_cores (dispatch_template_core)
case ("test_me")
call process%setup_cores (dispatch_test_me_core)
case default
call msg_bug ("process setup test cores: unsupported type string")
end select
else
call process%setup_cores (dispatch_test_me_core)
end if
end subroutine process_setup_test_cores
@ %def process_setup_test_cores
@
<<Process: process: TBP>>=
procedure :: get_connected_states => process_get_connected_states
<<Process: sub interfaces>>=
module function process_get_connected_states (process, i_component, &
connected_terms) result (connected)
type(connected_state_t), dimension(:), allocatable :: connected
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
type(connected_state_t), dimension(:), intent(in) :: connected_terms
end function process_get_connected_states
<<Process: procedures>>=
module function process_get_connected_states (process, i_component, &
connected_terms) result (connected)
type(connected_state_t), dimension(:), allocatable :: connected
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
type(connected_state_t), dimension(:), intent(in) :: connected_terms
integer :: i, i_conn
integer :: n_conn
n_conn = 0
do i = 1, process%get_n_terms ()
if (process%term(i)%i_component == i_component) then
n_conn = n_conn + 1
end if
end do
allocate (connected (n_conn))
i_conn = 1
do i = 1, process%get_n_terms ()
if (process%term(i)%i_component == i_component) then
connected (i_conn) = connected_terms(i)
i_conn = i_conn + 1
end if
end do
end function process_get_connected_states
@ %def process_get_connected_states
@
\subsection{NLO specifics}
These subroutines (and the NLO specific properties they work on) could
potentially be moved to [[pcm_nlo_t]] and used more generically in
[[process_t]] with an appropriate interface in [[pcm_t]]
TODO wk 2018: This is used only by event initialization, which deals
with an incomplete process object.
<<Process: process: TBP>>=
procedure :: init_nlo_settings => process_init_nlo_settings
<<Process: sub interfaces>>=
module subroutine process_init_nlo_settings (process, var_list)
class(process_t), intent(inout) :: process
type(var_list_t), intent(in), target :: var_list
end subroutine process_init_nlo_settings
<<Process: procedures>>=
module subroutine process_init_nlo_settings (process, var_list)
class(process_t), intent(inout) :: process
type(var_list_t), intent(in), target :: var_list
select type (pcm => process%pcm)
type is (pcm_nlo_t)
call pcm%init_nlo_settings (var_list)
if (debug_active (D_SUBTRACTION) .or. debug_active (D_VIRTUAL)) &
call pcm%settings%write ()
class default
call msg_fatal ("Attempt to set nlo_settings with a non-NLO pcm!")
end select
end subroutine process_init_nlo_settings
@ %def process_init_nlo_settings
@
<<Process: process: TBP>>=
generic :: get_nlo_type_component => get_nlo_type_component_single
procedure :: get_nlo_type_component_single => &
process_get_nlo_type_component_single
<<Process: sub interfaces>>=
elemental module function process_get_nlo_type_component_single &
(process, i_component) result (val)
integer :: val
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
end function process_get_nlo_type_component_single
<<Process: procedures>>=
elemental module function process_get_nlo_type_component_single &
(process, i_component) result (val)
integer :: val
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
val = process%component(i_component)%get_nlo_type ()
end function process_get_nlo_type_component_single
@ %def process_get_nlo_type_component_single
@
<<Process: process: TBP>>=
generic :: get_nlo_type_component => get_nlo_type_component_all
procedure :: get_nlo_type_component_all => process_get_nlo_type_component_all
<<Process: sub interfaces>>=
pure module function process_get_nlo_type_component_all &
(process) result (val)
integer, dimension(:), allocatable :: val
class(process_t), intent(in) :: process
end function process_get_nlo_type_component_all
<<Process: procedures>>=
pure module function process_get_nlo_type_component_all (process) result (val)
integer, dimension(:), allocatable :: val
class(process_t), intent(in) :: process
allocate (val (size (process%component)))
val = process%component%get_nlo_type ()
end function process_get_nlo_type_component_all
@ %def process_get_nlo_type_component_all
@
<<Process: process: TBP>>=
procedure :: is_nlo_calculation => process_is_nlo_calculation
<<Process: sub interfaces>>=
module function process_is_nlo_calculation (process) result (nlo)
logical :: nlo
class(process_t), intent(in) :: process
end function process_is_nlo_calculation
<<Process: procedures>>=
module function process_is_nlo_calculation (process) result (nlo)
logical :: nlo
class(process_t), intent(in) :: process
select type (pcm => process%pcm)
type is (pcm_nlo_t)
nlo = .true.
class default
nlo = .false.
end select
end function process_is_nlo_calculation
@ %def process_is_nlo_calculation
@
<<Process: process: TBP>>=
procedure :: get_negative_sf => process_get_negative_sf
<<Process: sub interfaces>>=
module function process_get_negative_sf (process) result (neg_sf)
logical :: neg_sf
class(process_t), intent(in) :: process
end function process_get_negative_sf
<<Process: procedures>>=
module function process_get_negative_sf (process) result (neg_sf)
logical :: neg_sf
class(process_t), intent(in) :: process
neg_sf = process%config%process_def%get_negative_sf ()
end function process_get_negative_sf
@ %def process_get_negative_sf
@
<<Process: process: TBP>>=
procedure :: is_combined_nlo_integration &
=> process_is_combined_nlo_integration
<<Process: sub interfaces>>=
module function process_is_combined_nlo_integration &
(process) result (combined)
logical :: combined
class(process_t), intent(in) :: process
end function process_is_combined_nlo_integration
<<Process: procedures>>=
module function process_is_combined_nlo_integration &
(process) result (combined)
logical :: combined
class(process_t), intent(in) :: process
select type (pcm => process%pcm)
type is (pcm_nlo_t)
combined = pcm%settings%combined_integration
class default
combined = .false.
end select
end function process_is_combined_nlo_integration
@ %def process_is_combined_nlo_integration
@
<<Process: process: TBP>>=
procedure :: component_is_real_finite => process_component_is_real_finite
<<Process: sub interfaces>>=
pure module function process_component_is_real_finite &
(process, i_component) result (val)
logical :: val
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
end function process_component_is_real_finite
<<Process: procedures>>=
pure module function process_component_is_real_finite &
(process, i_component) result (val)
logical :: val
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
val = process%component(i_component)%component_type == COMP_REAL_FIN
end function process_component_is_real_finite
@ %def process_component_is_real_finite
@ Return nlo data of a process component
<<Process: process: TBP>>=
procedure :: get_component_nlo_type => process_get_component_nlo_type
<<Process: sub interfaces>>=
elemental module function process_get_component_nlo_type &
(process, i_component) result (nlo_type)
integer :: nlo_type
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
end function process_get_component_nlo_type
<<Process: procedures>>=
elemental module function process_get_component_nlo_type &
(process, i_component) result (nlo_type)
integer :: nlo_type
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
nlo_type = process%component(i_component)%config%get_nlo_type ()
end function process_get_component_nlo_type
@ %def process_get_component_nlo_type
@ Return a pointer to the core that belongs to a component.
<<Process: process: TBP>>=
procedure :: get_component_core_ptr => process_get_component_core_ptr
<<Process: sub interfaces>>=
module function process_get_component_core_ptr &
(process, i_component) result (core)
class(process_t), intent(in), target :: process
integer, intent(in) :: i_component
class(prc_core_t), pointer :: core
end function process_get_component_core_ptr
<<Process: procedures>>=
module function process_get_component_core_ptr &
(process, i_component) result (core)
class(process_t), intent(in), target :: process
integer, intent(in) :: i_component
class(prc_core_t), pointer :: core
integer :: i_core
i_core = process%pcm%get_i_core(i_component)
core => process%core_entry(i_core)%core
end function process_get_component_core_ptr
@ %def process_get_component_core_ptr
@
<<Process: process: TBP>>=
procedure :: get_component_associated_born &
=> process_get_component_associated_born
<<Process: sub interfaces>>=
module function process_get_component_associated_born &
(process, i_component) result (i_born)
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
integer :: i_born
end function process_get_component_associated_born
<<Process: procedures>>=
module function process_get_component_associated_born &
(process, i_component) result (i_born)
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
integer :: i_born
i_born = process%component(i_component)%config%get_associated_born ()
end function process_get_component_associated_born
@ %def process_get_component_associated_born
@
<<Process: process: TBP>>=
procedure :: get_first_real_component => process_get_first_real_component
<<Process: sub interfaces>>=
module function process_get_first_real_component (process) result (i_real)
integer :: i_real
class(process_t), intent(in) :: process
end function process_get_first_real_component
<<Process: procedures>>=
module function process_get_first_real_component (process) result (i_real)
integer :: i_real
class(process_t), intent(in) :: process
i_real = process%component(1)%config%get_associated_real ()
end function process_get_first_real_component
@ %def process_get_first_real_component
@
<<Process: process: TBP>>=
procedure :: get_first_real_term => process_get_first_real_term
<<Process: sub interfaces>>=
module function process_get_first_real_term (process) result (i_real)
integer :: i_real
class(process_t), intent(in) :: process
integer :: i_component, i_term
end function process_get_first_real_term
<<Process: procedures>>=
module function process_get_first_real_term (process) result (i_real)
integer :: i_real
class(process_t), intent(in) :: process
integer :: i_component, i_term
i_component = process%component(1)%config%get_associated_real ()
i_real = 0
do i_term = 1, size (process%term)
if (process%term(i_term)%i_component == i_component) then
i_real = i_term
exit
end if
end do
if (i_real == 0) call msg_fatal ("Did not find associated real term!")
end function process_get_first_real_term
@ %def process_get_first_real_term
@
<<Process: process: TBP>>=
procedure :: get_associated_real_fin => process_get_associated_real_fin
<<Process: sub interfaces>>=
elemental module function process_get_associated_real_fin &
(process, i_component) result (i_real)
integer :: i_real
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
end function process_get_associated_real_fin
<<Process: procedures>>=
elemental module function process_get_associated_real_fin &
(process, i_component) result (i_real)
integer :: i_real
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
i_real = process%component(i_component)%config%get_associated_real_fin ()
end function process_get_associated_real_fin
@ %def process_get_associated_real_fin
@
<<Process: process: TBP>>=
procedure :: select_i_term => process_select_i_term
<<Process: sub interfaces>>=
pure module function process_select_i_term (process, i_mci) result (i_term)
integer :: i_term
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
end function process_select_i_term
<<Process: procedures>>=
pure module function process_select_i_term (process, i_mci) result (i_term)
integer :: i_term
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
integer :: i_component, i_sub
i_component = process%mci_entry(i_mci)%i_component(1)
i_term = process%component(i_component)%i_term(1)
i_sub = process%term(i_term)%i_sub
if (i_sub > 0) &
i_term = process%term(i_sub)%i_term_global
end function process_select_i_term
@ %def process_select_i_term
@ Would be better to do this at the level of the writer of the core but
one has to bring NLO information there.
<<Process: process: TBP>>=
procedure :: prepare_any_external_code &
=> process_prepare_any_external_code
<<Process: sub interfaces>>=
module subroutine process_prepare_any_external_code (process)
class(process_t), intent(inout), target :: process
end subroutine process_prepare_any_external_code
<<Process: procedures>>=
module subroutine process_prepare_any_external_code (process)
class(process_t), intent(inout), target :: process
integer :: i
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
"process_prepare_external_code")
associate (pcm => process%pcm)
do i = 1, pcm%n_cores
call pcm%prepare_any_external_code ( &
process%core_entry(i), i, &
process%get_library_name (), &
process%config%model, &
process%env%get_var_list_ptr ())
end do
end associate
end subroutine process_prepare_any_external_code
@ %def process_prepare_any_external_code
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Process config}
<<[[process_config.f90]]>>=
<<File header>>
module process_config
<<Use kinds>>
<<Use strings>>
use os_interface
use sf_base
use sf_mappings
use mappings, only: mapping_defaults_t
use phs_forests, only: phs_parameters_t
use sm_qcd
use integration_results
use flavors
use interactions
use model_data
use models
use process_libraries
use process_constants
use prc_core
use beams
use mci_base
use beam_structures
use dispatch_beams, only: dispatch_qcd
use phs_base
use expr_base
use variables
<<Standard module head>>
<<Process config: public>>
<<Process config: parameters>>
<<Process config: types>>
interface
<<Process config: sub interfaces>>
end interface
contains
<<Process config: main procedures>>
end module process_config
@ %def process_config
@
<<[[process_config_sub.f90]]>>=
<<File header>>
submodule (process_config) process_config_s
use format_utils, only: write_separator
use io_units
use diagnostics
use md5
use physics_defs
use helicities
use colors
use quantum_numbers
use state_matrices
use prc_external
use prc_openloops, only: prc_openloops_t
use prc_threshold, only: prc_threshold_t
use blha_olp_interfaces, only: prc_blha_t
implicit none
contains
<<Process config: procedures>>
end submodule process_config_s
@ %def process_config_s
@ Identifiers for the NLO setup.
<<Process config: parameters>>=
integer, parameter, public :: COMP_DEFAULT = 0
integer, parameter, public :: COMP_REAL_FIN = 1
integer, parameter, public :: COMP_MASTER = 2
integer, parameter, public :: COMP_VIRT = 3
integer, parameter, public :: COMP_REAL = 4
integer, parameter, public :: COMP_REAL_SING = 5
integer, parameter, public :: COMP_MISMATCH = 6
integer, parameter, public :: COMP_PDF = 7
integer, parameter, public :: COMP_SUB = 8
integer, parameter, public :: COMP_RESUM = 9
@
\subsection{Output selection flags}
We declare a number of identifiers for write methods, so they only
displays selected parts. The identifiers can be supplied to the [[vlist]]
array argument of the standard F2008 derived-type writer call.
<<Process config: parameters>>=
integer, parameter, public :: F_PACIFY = 1
integer, parameter, public :: F_SHOW_VAR_LIST = 11
integer, parameter, public :: F_SHOW_EXPRESSIONS = 12
integer, parameter, public :: F_SHOW_LIB = 13
integer, parameter, public :: F_SHOW_MODEL = 14
integer, parameter, public :: F_SHOW_QCD = 15
integer, parameter, public :: F_SHOW_OS_DATA = 16
integer, parameter, public :: F_SHOW_RNG = 17
integer, parameter, public :: F_SHOW_BEAMS = 18
@ %def SHOW_VAR_LIST
@ %def SHOW_EXPRESSIONS
@
This is a simple function that returns true if a flag value is present in
[[v_list]], but not its negative. If neither is present, it returns
[[default]].
<<Process config: public>>=
public :: flagged
<<Process config: sub interfaces>>=
module function flagged (v_list, id, def) result (flag)
logical :: flag
integer, dimension(:), intent(in) :: v_list
integer, intent(in) :: id
logical, intent(in), optional :: def
end function flagged
<<Process config: procedures>>=
module function flagged (v_list, id, def) result (flag)
logical :: flag
integer, dimension(:), intent(in) :: v_list
integer, intent(in) :: id
logical, intent(in), optional :: def
logical :: default_result
default_result = .false.; if (present (def)) default_result = def
if (default_result) then
flag = all (v_list /= -id)
else
flag = all (v_list /= -id) .and. any (v_list == id)
end if
end function flagged
@ %def flagged
@
Related: if flag is set (unset), append [[value]] (its negative) to the
[[v_list]], respectively. [[v_list]] must be allocated.
<<Process config: public>>=
public :: set_flag
<<Process config: sub interfaces>>=
module subroutine set_flag (v_list, value, flag)
integer, dimension(:), intent(inout), allocatable :: v_list
integer, intent(in) :: value
logical, intent(in), optional :: flag
end subroutine set_flag
<<Process config: procedures>>=
module subroutine set_flag (v_list, value, flag)
integer, dimension(:), intent(inout), allocatable :: v_list
integer, intent(in) :: value
logical, intent(in), optional :: flag
if (present (flag)) then
if (flag) then
v_list = [v_list, value]
else
v_list = [v_list, -value]
end if
end if
end subroutine set_flag
@ %def set_flag
@
\subsection{Generic configuration data}
This information concerns physical and technical properties of the
process. It is fixed upon initialization, using data from the
process specification and the variable list.
The number [[n_in]] is the number of incoming beam particles,
simultaneously the number of incoming partons, 1 for a decay and 2 for
a scattering process. (The number of outgoing partons may depend on
the process component.)
The number [[n_components]] is the number of components that constitute
the current process.
The number [[n_terms]] is the number of distinct contributions to the
scattering matrix that constitute the current process. Each component
may generate several terms.
The number [[n_mci]] is the number of independent MC
integration configurations that this process uses. Distinct process
components that share a MCI configuration may be combined pointwise.
(Nevertheless, a given MC variable set may correspond to several
``nearby'' kinematical configurations.) This is also the number of
distinct sampling-function results that this process can generate.
Process components that use distinct variable sets are added only once
after an integration pass has completed.
The [[model]] pointer identifies the physics model and its
parameters. This is a pointer to an external object.
Various [[parse_node_t]] objects are taken from the SINDARIN input.
They encode expressions for evaluating cuts and scales. The
workspaces for evaluating those expressions are set up in the
[[effective_state]] subobjects. Note that these are really pointers,
so the actual nodes are not stored inside the process object.
The [[md5sum]] is taken and used to verify the process configuration
when re-reading data from file.
<<Process config: public>>=
public :: process_config_data_t
<<Process config: types>>=
type :: process_config_data_t
class(process_def_t), pointer :: process_def => null ()
integer :: n_in = 0
integer :: n_components = 0
integer :: n_terms = 0
integer :: n_mci = 0
type(string_t) :: model_name
class(model_data_t), pointer :: model => null ()
type(qcd_t) :: qcd
class(expr_factory_t), allocatable :: ef_cuts
class(expr_factory_t), allocatable :: ef_scale
class(expr_factory_t), allocatable :: ef_fac_scale
class(expr_factory_t), allocatable :: ef_ren_scale
class(expr_factory_t), allocatable :: ef_weight
character(32) :: md5sum = ""
contains
<<Process config: process config data: TBP>>
end type process_config_data_t
@ %def process_config_data_t
@ Here, we may compress the expressions for cuts etc.
<<Process config: process config data: TBP>>=
procedure :: write => process_config_data_write
<<Process config: sub interfaces>>=
module subroutine process_config_data_write &
(config, u, counters, model, expressions)
class(process_config_data_t), intent(in) :: config
integer, intent(in) :: u
logical, intent(in) :: counters
logical, intent(in) :: model
logical, intent(in) :: expressions
end subroutine process_config_data_write
<<Process config: procedures>>=
module subroutine process_config_data_write &
(config, u, counters, model, expressions)
class(process_config_data_t), intent(in) :: config
integer, intent(in) :: u
logical, intent(in) :: counters
logical, intent(in) :: model
logical, intent(in) :: expressions
write (u, "(1x,A)") "Configuration data:"
if (counters) then
write (u, "(3x,A,I0)") "Number of incoming particles = ", &
config%n_in
write (u, "(3x,A,I0)") "Number of process components = ", &
config%n_components
write (u, "(3x,A,I0)") "Number of process terms = ", &
config%n_terms
write (u, "(3x,A,I0)") "Number of MCI configurations = ", &
config%n_mci
end if
if (associated (config%model)) then
write (u, "(3x,A,A)") "Model = ", char (config%model_name)
if (model) then
call write_separator (u)
call config%model%write (u)
call write_separator (u)
end if
else
write (u, "(3x,A,A,A)") "Model = ", char (config%model_name), &
" [not associated]"
end if
call config%qcd%write (u, show_md5sum = .false.)
call write_separator (u)
if (expressions) then
if (allocated (config%ef_cuts)) then
call write_separator (u)
write (u, "(3x,A)") "Cut expression:"
call config%ef_cuts%write (u)
end if
if (allocated (config%ef_scale)) then
call write_separator (u)
write (u, "(3x,A)") "Scale expression:"
call config%ef_scale%write (u)
end if
if (allocated (config%ef_fac_scale)) then
call write_separator (u)
write (u, "(3x,A)") "Factorization scale expression:"
call config%ef_fac_scale%write (u)
end if
if (allocated (config%ef_ren_scale)) then
call write_separator (u)
write (u, "(3x,A)") "Renormalization scale expression:"
call config%ef_ren_scale%write (u)
end if
if (allocated (config%ef_weight)) then
call write_separator (u)
write (u, "(3x,A)") "Weight expression:"
call config%ef_weight%write (u)
end if
else
call write_separator (u)
write (u, "(3x,A)") "Expressions (cut, scales, weight): [not shown]"
end if
if (config%md5sum /= "") then
call write_separator (u)
write (u, "(3x,A,A,A)") "MD5 sum (config) = '", config%md5sum, "'"
end if
end subroutine process_config_data_write
@ %def process_config_data_write
@ Initialize. We use information from the process metadata and from
the process library, given the process ID. We also store the
currently active OS data set.
The model pointer references the model data within the [[env]] record. That
should be an instance of the global model.
We initialize the QCD object, unless the environment information is unavailable
(unit tests).
The RNG factory object is imported by moving the allocation.
Gfortran 7/8/9 bug: has to remain in the main module:
<<Process config: process config data: TBP>>=
procedure :: init => process_config_data_init
<<Process config: main procedures>>=
subroutine process_config_data_init (config, meta, env)
class(process_config_data_t), intent(out) :: config
type(process_metadata_t), intent(in) :: meta
type(process_environment_t), intent(in) :: env
config%process_def => env%lib%get_process_def_ptr (meta%id)
config%n_in = config%process_def%get_n_in ()
config%n_components = size (meta%component_id)
config%model => env%get_model_ptr ()
config%model_name = config%model%get_name ()
if (env%got_var_list ()) then
call dispatch_qcd &
(config%qcd, env%get_var_list_ptr (), env%get_os_data ())
end if
end subroutine process_config_data_init
@ %def process_config_data_init
@ Return a copy of the QCD data block.
<<Process config: process config data: TBP>>=
procedure :: get_qcd => process_config_data_get_qcd
<<Process config: sub interfaces>>=
module function process_config_data_get_qcd (config) result (qcd)
class(process_config_data_t), intent(in) :: config
type(qcd_t) :: qcd
end function process_config_data_get_qcd
<<Process config: procedures>>=
module function process_config_data_get_qcd (config) result (qcd)
class(process_config_data_t), intent(in) :: config
type(qcd_t) :: qcd
qcd = config%qcd
end function process_config_data_get_qcd
@ %def process_config_data_get_qcd
@ Compute the MD5 sum of the configuration data. This encodes, in
particular, the model and the expressions for cut, scales, weight,
etc. It should not contain the IDs and number of components, etc.,
since the MD5 sum should be useful for integrating individual
components.
This is done only once. If the MD5 sum is nonempty, the calculation
is skipped.
<<Process config: process config data: TBP>>=
procedure :: compute_md5sum => process_config_data_compute_md5sum
<<Process config: sub interfaces>>=
module subroutine process_config_data_compute_md5sum (config)
class(process_config_data_t), intent(inout) :: config
end subroutine process_config_data_compute_md5sum
<<Process config: procedures>>=
module subroutine process_config_data_compute_md5sum (config)
class(process_config_data_t), intent(inout) :: config
integer :: u
if (config%md5sum == "") then
u = free_unit ()
open (u, status = "scratch", action = "readwrite")
call config%write (u, counters = .false., &
model = .true., expressions = .true.)
rewind (u)
config%md5sum = md5sum (u)
close (u)
end if
end subroutine process_config_data_compute_md5sum
@ %def process_config_data_compute_md5sum
@
<<Process config: process config data: TBP>>=
procedure :: get_md5sum => process_config_data_get_md5sum
<<Process config: sub interfaces>>=
pure module function process_config_data_get_md5sum (config) result (md5)
character(32) :: md5
class(process_config_data_t), intent(in) :: config
end function process_config_data_get_md5sum
<<Process config: procedures>>=
pure module function process_config_data_get_md5sum (config) result (md5)
character(32) :: md5
class(process_config_data_t), intent(in) :: config
md5 = config%md5sum
end function process_config_data_get_md5sum
@ %def process_config_data_get_md5sum
@
\subsection{Environment}
This record stores a snapshot of the process environment at the point where
the process object is created.
Model and variable list are implemented as pointer, so they always have the
[[target]] attribute.
For unit-testing purposes, setting the var list is optional. If not set, the
pointer is null.
<<Process config: public>>=
public :: process_environment_t
<<Process config: types>>=
type :: process_environment_t
private
type(model_t), pointer :: model => null ()
type(var_list_t), pointer :: var_list => null ()
logical :: var_list_is_set = .false.
type(process_library_t), pointer :: lib => null ()
type(beam_structure_t) :: beam_structure
type(os_data_t) :: os_data
contains
<<Process config: process environment: TBP>>
end type process_environment_t
@ %def process_environment_t
@ Model and local var list are snapshots and need a finalizer.
<<Process config: process environment: TBP>>=
procedure :: final => process_environment_final
<<Process config: sub interfaces>>=
module subroutine process_environment_final (env)
class(process_environment_t), intent(inout) :: env
end subroutine process_environment_final
<<Process config: procedures>>=
module subroutine process_environment_final (env)
class(process_environment_t), intent(inout) :: env
if (associated (env%model)) then
call env%model%final ()
deallocate (env%model)
end if
if (associated (env%var_list)) then
call env%var_list%final (follow_link=.true.)
deallocate (env%var_list)
end if
end subroutine process_environment_final
@ %def process_environment_final
@ Output, DTIO compatible.
<<Process config: process environment: TBP>>=
procedure :: write => process_environment_write
procedure :: write_formatted => process_environment_write_formatted
! generic :: write (formatted) => write_formatted
<<Process config: sub interfaces>>=
module subroutine process_environment_write (env, unit, &
show_var_list, show_model, show_lib, show_beams, show_os_data)
class(process_environment_t), intent(in) :: env
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_var_list
logical, intent(in), optional :: show_model
logical, intent(in), optional :: show_lib
logical, intent(in), optional :: show_beams
logical, intent(in), optional :: show_os_data
end subroutine process_environment_write
<<Process config: procedures>>=
module subroutine process_environment_write (env, unit, &
show_var_list, show_model, show_lib, show_beams, show_os_data)
class(process_environment_t), intent(in) :: env
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_var_list
logical, intent(in), optional :: show_model
logical, intent(in), optional :: show_lib
logical, intent(in), optional :: show_beams
logical, intent(in), optional :: show_os_data
integer :: u, iostat
integer, dimension(:), allocatable :: v_list
character(0) :: iomsg
u = given_output_unit (unit)
allocate (v_list (0))
call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list)
call set_flag (v_list, F_SHOW_MODEL, show_model)
call set_flag (v_list, F_SHOW_LIB, show_lib)
call set_flag (v_list, F_SHOW_BEAMS, show_beams)
call set_flag (v_list, F_SHOW_OS_DATA, show_os_data)
call env%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg)
end subroutine process_environment_write
@ %def process_environment_write
@ DTIO standard write.
<<Process config: sub interfaces>>=
module subroutine process_environment_write_formatted &
(dtv, unit, iotype, v_list, iostat, iomsg)
class(process_environment_t), intent(in) :: dtv
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, dimension(:), intent(in) :: v_list
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
end subroutine process_environment_write_formatted
<<Process config: procedures>>=
module subroutine process_environment_write_formatted &
(dtv, unit, iotype, v_list, iostat, iomsg)
class(process_environment_t), intent(in) :: dtv
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, dimension(:), intent(in) :: v_list
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
associate (env => dtv)
if (flagged (v_list, F_SHOW_VAR_LIST, .true.)) then
write (unit, "(1x,A)") "Variable list:"
if (associated (env%var_list)) then
call write_separator (unit)
call env%var_list%write (unit)
else
write (unit, "(3x,A)") "[not allocated]"
end if
call write_separator (unit)
end if
if (flagged (v_list, F_SHOW_MODEL, .true.)) then
write (unit, "(1x,A)") "Model:"
if (associated (env%model)) then
call write_separator (unit)
call env%model%write (unit)
else
write (unit, "(3x,A)") "[not allocated]"
end if
call write_separator (unit)
end if
if (flagged (v_list, F_SHOW_LIB, .true.)) then
write (unit, "(1x,A)") "Process library:"
if (associated (env%lib)) then
call write_separator (unit)
call env%lib%write (unit)
else
write (unit, "(3x,A)") "[not allocated]"
end if
end if
if (flagged (v_list, F_SHOW_BEAMS, .true.)) then
call write_separator (unit)
call env%beam_structure%write (unit)
end if
if (flagged (v_list, F_SHOW_OS_DATA, .true.)) then
write (unit, "(1x,A)") "Operating-system data:"
call write_separator (unit)
call env%os_data%write (unit)
end if
end associate
iostat = 0
end subroutine process_environment_write_formatted
@ %def process_environment_write_formatted
@ Initialize: Make a snapshot of the provided model. Make a link to the
current process library.
Also make a snapshot of the variable list, if provided. If none is
provided, there is an empty variable list nevertheless, so a pointer
lookup does not return null.
If no beam structure is provided, the beam-structure member is empty and will
yield a number of zero beams when queried.
<<Process config: process environment: TBP>>=
procedure :: init => process_environment_init
<<Process config: sub interfaces>>=
module subroutine process_environment_init &
(env, model, lib, os_data, var_list, beam_structure)
class(process_environment_t), intent(out) :: env
type(model_t), intent(in), target :: model
type(process_library_t), intent(in), target :: lib
type(os_data_t), intent(in) :: os_data
type(var_list_t), intent(in), target, optional :: var_list
type(beam_structure_t), intent(in), optional :: beam_structure
end subroutine process_environment_init
<<Process config: procedures>>=
module subroutine process_environment_init &
(env, model, lib, os_data, var_list, beam_structure)
class(process_environment_t), intent(out) :: env
type(model_t), intent(in), target :: model
type(process_library_t), intent(in), target :: lib
type(os_data_t), intent(in) :: os_data
type(var_list_t), intent(in), target, optional :: var_list
type(beam_structure_t), intent(in), optional :: beam_structure
allocate (env%model)
call env%model%init_instance (model)
env%lib => lib
env%os_data = os_data
allocate (env%var_list)
if (present (var_list)) then
call env%var_list%init_snapshot (var_list, follow_link=.true.)
env%var_list_is_set = .true.
end if
if (present (beam_structure)) then
env%beam_structure = beam_structure
end if
end subroutine process_environment_init
@ %def process_environment_init
@ Indicate whether a variable list has been provided upon initialization.
<<Process config: process environment: TBP>>=
procedure :: got_var_list => process_environment_got_var_list
<<Process config: sub interfaces>>=
module function process_environment_got_var_list (env) result (flag)
class(process_environment_t), intent(in) :: env
logical :: flag
end function process_environment_got_var_list
<<Process config: procedures>>=
module function process_environment_got_var_list (env) result (flag)
class(process_environment_t), intent(in) :: env
logical :: flag
flag = env%var_list_is_set
end function process_environment_got_var_list
@ %def process_environment_got_var_list
@ Return a pointer to the variable list.
<<Process config: process environment: TBP>>=
procedure :: get_var_list_ptr => process_environment_get_var_list_ptr
<<Process config: sub interfaces>>=
module function process_environment_get_var_list_ptr (env) result (var_list)
class(process_environment_t), intent(in) :: env
type(var_list_t), pointer :: var_list
end function process_environment_get_var_list_ptr
<<Process config: procedures>>=
module function process_environment_get_var_list_ptr (env) result (var_list)
class(process_environment_t), intent(in) :: env
type(var_list_t), pointer :: var_list
var_list => env%var_list
end function process_environment_get_var_list_ptr
@ %def process_environment_get_var_list_ptr
@ Return a pointer to the model, if it exists.
<<Process config: process environment: TBP>>=
procedure :: get_model_ptr => process_environment_get_model_ptr
<<Process config: sub interfaces>>=
module function process_environment_get_model_ptr (env) result (model)
class(process_environment_t), intent(in) :: env
type(model_t), pointer :: model
end function process_environment_get_model_ptr
<<Process config: procedures>>=
module function process_environment_get_model_ptr (env) result (model)
class(process_environment_t), intent(in) :: env
type(model_t), pointer :: model
model => env%model
end function process_environment_get_model_ptr
@ %def process_environment_get_model_ptr
@ Return the process library pointer.
<<Process config: process environment: TBP>>=
procedure :: get_lib_ptr => process_environment_get_lib_ptr
<<Process config: sub interfaces>>=
module function process_environment_get_lib_ptr (env) result (lib)
class(process_environment_t), intent(inout) :: env
type(process_library_t), pointer :: lib
end function process_environment_get_lib_ptr
<<Process config: procedures>>=
module function process_environment_get_lib_ptr (env) result (lib)
class(process_environment_t), intent(inout) :: env
type(process_library_t), pointer :: lib
lib => env%lib
end function process_environment_get_lib_ptr
@ %def process_environment_get_lib_ptr
@ Clear the process library pointer, in case the library is deleted.
<<Process config: process environment: TBP>>=
procedure :: reset_lib_ptr => process_environment_reset_lib_ptr
<<Process config: sub interfaces>>=
module subroutine process_environment_reset_lib_ptr (env)
class(process_environment_t), intent(inout) :: env
end subroutine process_environment_reset_lib_ptr
<<Process config: procedures>>=
module subroutine process_environment_reset_lib_ptr (env)
class(process_environment_t), intent(inout) :: env
env%lib => null ()
end subroutine process_environment_reset_lib_ptr
@ %def process_environment_reset_lib_ptr
@ Check whether the process library has changed, in case the library is
recompiled, etc.
<<Process config: process environment: TBP>>=
procedure :: check_lib_sanity => process_environment_check_lib_sanity
<<Process config: sub interfaces>>=
module subroutine process_environment_check_lib_sanity (env, meta)
class(process_environment_t), intent(in) :: env
type(process_metadata_t), intent(in) :: meta
end subroutine process_environment_check_lib_sanity
<<Process config: procedures>>=
module subroutine process_environment_check_lib_sanity (env, meta)
class(process_environment_t), intent(in) :: env
type(process_metadata_t), intent(in) :: meta
if (associated (env%lib)) then
if (env%lib%get_update_counter () /= meta%lib_update_counter) then
call msg_fatal ("Process '" // char (meta%id) &
// "': library has been recompiled after integration")
end if
end if
end subroutine process_environment_check_lib_sanity
@ %def process_environment_check_lib_sanity
@ Fill the [[data]] block using the appropriate process-library access entry.
<<Process config: process environment: TBP>>=
procedure :: fill_process_constants => &
process_environment_fill_process_constants
<<Process config: sub interfaces>>=
module subroutine process_environment_fill_process_constants &
(env, id, i_component, data)
class(process_environment_t), intent(in) :: env
type(string_t), intent(in) :: id
integer, intent(in) :: i_component
type(process_constants_t), intent(out) :: data
end subroutine process_environment_fill_process_constants
<<Process config: procedures>>=
module subroutine process_environment_fill_process_constants &
(env, id, i_component, data)
class(process_environment_t), intent(in) :: env
type(string_t), intent(in) :: id
integer, intent(in) :: i_component
type(process_constants_t), intent(out) :: data
call env%lib%fill_constants (id, i_component, data)
end subroutine process_environment_fill_process_constants
@ %def process_environment_fill_process_constants
@ Return the entire beam structure.
<<Process config: process environment: TBP>>=
procedure :: get_beam_structure => process_environment_get_beam_structure
<<Process config: sub interfaces>>=
module function process_environment_get_beam_structure &
(env) result (beam_structure)
class(process_environment_t), intent(in) :: env
type(beam_structure_t) :: beam_structure
end function process_environment_get_beam_structure
<<Process config: procedures>>=
module function process_environment_get_beam_structure &
(env) result (beam_structure)
class(process_environment_t), intent(in) :: env
type(beam_structure_t) :: beam_structure
beam_structure = env%beam_structure
end function process_environment_get_beam_structure
@ %def process_environment_get_beam_structure
@ Check the beam structure for PDFs.
<<Process config: process environment: TBP>>=
procedure :: has_pdfs => process_environment_has_pdfs
<<Process config: sub interfaces>>=
module function process_environment_has_pdfs (env) result (flag)
class(process_environment_t), intent(in) :: env
logical :: flag
end function process_environment_has_pdfs
<<Process config: procedures>>=
module function process_environment_has_pdfs (env) result (flag)
class(process_environment_t), intent(in) :: env
logical :: flag
flag = env%beam_structure%has_pdf ()
end function process_environment_has_pdfs
@ %def process_environment_has_pdfs
@ Check the beam structure for polarized beams.
<<Process config: process environment: TBP>>=
procedure :: has_polarized_beams => process_environment_has_polarized_beams
<<Process config: sub interfaces>>=
module function process_environment_has_polarized_beams (env) result (flag)
class(process_environment_t), intent(in) :: env
logical :: flag
end function process_environment_has_polarized_beams
<<Process config: procedures>>=
module function process_environment_has_polarized_beams (env) result (flag)
class(process_environment_t), intent(in) :: env
logical :: flag
flag = env%beam_structure%has_polarized_beams ()
end function process_environment_has_polarized_beams
@ %def process_environment_has_polarized_beams
@ Return a copy of the OS data block.
<<Process config: process environment: TBP>>=
procedure :: get_os_data => process_environment_get_os_data
<<Process config: sub interfaces>>=
module function process_environment_get_os_data (env) result (os_data)
class(process_environment_t), intent(in) :: env
type(os_data_t) :: os_data
end function process_environment_get_os_data
<<Process config: procedures>>=
module function process_environment_get_os_data (env) result (os_data)
class(process_environment_t), intent(in) :: env
type(os_data_t) :: os_data
os_data = env%os_data
end function process_environment_get_os_data
@ %def process_environment_get_os_data
@
\subsection{Metadata}
This information describes the process. It is fixed upon initialization.
The [[id]] string is the name of the process object, as given by the
user. The matrix element generator will use this string for naming
Fortran procedures and types, so it should qualify as a Fortran name.
The [[num_id]] is meaningful if nonzero. It is used for communication
with external programs or file standards which do not support string IDs.
The [[run_id]] string distinguishes among several runs for the same
process. It identifies process instances with respect to adapted
integration grids and similar run-specific data. The run ID is kept
when copying processes for creating instances, however, so it does not
distinguish event samples.
The [[lib_name]] identifies the process library where the process
definition and the process driver are located.
The [[lib_index]] is the index of entry in the process library that
corresponds to the current process.
The [[component_id]] array identifies the individual process components.
The [[component_description]] is an array of human-readable strings
that characterize the process components, for instance [[a, b => c, d]].
The [[active]] mask array marks those components which are active. The others
are skipped.
<<Process config: public>>=
public :: process_metadata_t
<<Process config: types>>=
type :: process_metadata_t
integer :: type = PRC_UNKNOWN
type(string_t) :: id
integer :: num_id = 0
type(string_t) :: run_id
type(string_t), allocatable :: lib_name
integer :: lib_update_counter = 0
integer :: lib_index = 0
integer :: n_components = 0
type(string_t), dimension(:), allocatable :: component_id
type(string_t), dimension(:), allocatable :: component_description
logical, dimension(:), allocatable :: active
contains
<<Process config: process metadata: TBP>>
end type process_metadata_t
@ %def process_metadata_t
@ Output: ID and run ID.
We write the variable list only upon request.
<<Process config: process metadata: TBP>>=
procedure :: write => process_metadata_write
<<Process config: sub interfaces>>=
module subroutine process_metadata_write (meta, u, screen)
class(process_metadata_t), intent(in) :: meta
integer, intent(in) :: u
logical, intent(in) :: screen
end subroutine process_metadata_write
<<Process config: procedures>>=
module subroutine process_metadata_write (meta, u, screen)
class(process_metadata_t), intent(in) :: meta
integer, intent(in) :: u
logical, intent(in) :: screen
integer :: i
select case (meta%type)
case (PRC_UNKNOWN)
if (screen) then
write (msg_buffer, "(A)") "Process [undefined]"
else
write (u, "(1x,A)") "Process [undefined]"
end if
return
case (PRC_DECAY)
if (screen) then
write (msg_buffer, "(A,1x,A,A,A)") "Process [decay]:", &
"'", char (meta%id), "'"
else
write (u, "(1x,A)", advance="no") "Process [decay]:"
end if
case (PRC_SCATTERING)
if (screen) then
write (msg_buffer, "(A,1x,A,A,A)") "Process [scattering]:", &
"'", char (meta%id), "'"
else
write (u, "(1x,A)", advance="no") "Process [scattering]:"
end if
case default
call msg_bug ("process_write: undefined process type")
end select
if (screen) then
call msg_message ()
else
write (u, "(1x,A,A,A)") "'", char (meta%id), "'"
end if
if (meta%num_id /= 0) then
if (screen) then
write (msg_buffer, "(2x,A,I0)") "ID (num) = ", meta%num_id
call msg_message ()
else
write (u, "(3x,A,I0)") "ID (num) = ", meta%num_id
end if
end if
if (screen) then
if (meta%run_id /= "") then
write (msg_buffer, "(2x,A,A,A)") "Run ID = '", &
char (meta%run_id), "'"
call msg_message ()
end if
else
write (u, "(3x,A,A,A)") "Run ID = '", char (meta%run_id), "'"
end if
if (allocated (meta%lib_name)) then
if (screen) then
write (msg_buffer, "(2x,A,A,A)") "Library name = '", &
char (meta%lib_name), "'"
call msg_message ()
else
write (u, "(3x,A,A,A)") "Library name = '", &
char (meta%lib_name), "'"
end if
else
if (screen) then
write (msg_buffer, "(2x,A)") "Library name = [not associated]"
call msg_message ()
else
write (u, "(3x,A)") "Library name = [not associated]"
end if
end if
if (screen) then
write (msg_buffer, "(2x,A,I0)") "Process index = ", meta%lib_index
call msg_message ()
else
write (u, "(3x,A,I0)") "Process index = ", meta%lib_index
end if
if (allocated (meta%component_id)) then
if (screen) then
if (any (meta%active)) then
write (msg_buffer, "(2x,A)") "Process components:"
else
write (msg_buffer, "(2x,A)") "Process components: [none]"
end if
call msg_message ()
else
write (u, "(3x,A)") "Process components:"
end if
do i = 1, size (meta%component_id)
if (.not. meta%active(i)) cycle
if (screen) then
write (msg_buffer, "(4x,I0,9A)") i, ": '", &
char (meta%component_id (i)), "': ", &
char (meta%component_description (i))
call msg_message ()
else
write (u, "(5x,I0,9A)") i, ": '", &
char (meta%component_id (i)), "': ", &
char (meta%component_description (i))
end if
end do
end if
if (screen) then
write (msg_buffer, "(A)") repeat ("-", 72)
call msg_message ()
else
call write_separator (u)
end if
end subroutine process_metadata_write
@ %def process_metadata_write
@ Short output: list components.
<<Process config: process metadata: TBP>>=
procedure :: show => process_metadata_show
<<Process config: sub interfaces>>=
module subroutine process_metadata_show (meta, u, model_name)
class(process_metadata_t), intent(in) :: meta
integer, intent(in) :: u
type(string_t), intent(in) :: model_name
end subroutine process_metadata_show
<<Process config: procedures>>=
module subroutine process_metadata_show (meta, u, model_name)
class(process_metadata_t), intent(in) :: meta
integer, intent(in) :: u
type(string_t), intent(in) :: model_name
integer :: i
select case (meta%type)
case (PRC_UNKNOWN)
write (u, "(A)") "Process: [undefined]"
return
case default
write (u, "(A)", advance="no") "Process:"
end select
write (u, "(1x,A)", advance="no") char (meta%id)
select case (meta%num_id)
case (0)
case default
write (u, "(1x,'(',I0,')')", advance="no") meta%num_id
end select
select case (char (model_name))
case ("")
case default
write (u, "(1x,'[',A,']')", advance="no") char (model_name)
end select
write (u, *)
if (allocated (meta%component_id)) then
do i = 1, size (meta%component_id)
if (meta%active(i)) then
write (u, "(2x,I0,':',1x,A)") i, &
char (meta%component_description (i))
end if
end do
end if
end subroutine process_metadata_show
@ %def process_metadata_show
@ Initialize. Find process ID and run ID.
Also find the process ID in the process library and retrieve some metadata from
there.
<<Process config: process metadata: TBP>>=
procedure :: init => process_metadata_init
<<Process config: sub interfaces>>=
module subroutine process_metadata_init (meta, id, lib, var_list)
class(process_metadata_t), intent(out) :: meta
type(string_t), intent(in) :: id
type(process_library_t), intent(in), target :: lib
type(var_list_t), intent(in) :: var_list
end subroutine process_metadata_init
<<Process config: procedures>>=
module subroutine process_metadata_init (meta, id, lib, var_list)
class(process_metadata_t), intent(out) :: meta
type(string_t), intent(in) :: id
type(process_library_t), intent(in), target :: lib
type(var_list_t), intent(in) :: var_list
select case (lib%get_n_in (id))
case (1); meta%type = PRC_DECAY
case (2); meta%type = PRC_SCATTERING
case default
call msg_bug ("Process '" // char (id) // "': impossible n_in")
end select
meta%id = id
meta%run_id = var_list%get_sval (var_str ("$run_id"))
allocate (meta%lib_name)
meta%lib_name = lib%get_name ()
meta%lib_update_counter = lib%get_update_counter ()
if (lib%contains (id)) then
meta%lib_index = lib%get_entry_index (id)
meta%num_id = lib%get_num_id (id)
call lib%get_component_list (id, meta%component_id)
meta%n_components = size (meta%component_id)
call lib%get_component_description_list &
(id, meta%component_description)
allocate (meta%active (meta%n_components), source = .true.)
else
call msg_fatal ("Process library does not contain process '" &
// char (id) // "'")
end if
if (.not. lib%is_active ()) then
call msg_bug ("Process init: inactive library not handled yet")
end if
end subroutine process_metadata_init
@ %def process_metadata_init
@ Mark a component as inactive.
<<Process config: process metadata: TBP>>=
procedure :: deactivate_component => process_metadata_deactivate_component
<<Process config: sub interfaces>>=
module subroutine process_metadata_deactivate_component (meta, i)
class(process_metadata_t), intent(inout) :: meta
integer, intent(in) :: i
end subroutine process_metadata_deactivate_component
<<Process config: procedures>>=
module subroutine process_metadata_deactivate_component (meta, i)
class(process_metadata_t), intent(inout) :: meta
integer, intent(in) :: i
call msg_message ("Process component '" &
// char (meta%component_id(i)) // "': matrix element vanishes")
meta%active(i) = .false.
end subroutine process_metadata_deactivate_component
@ %def process_metadata_deactivate_component
@
\subsection{Phase-space configuration}
A process can have a number of independent phase-space configuration entries,
depending on the process definition and evaluation algorithm. Each entry
holds various configuration-parameter data and the actual [[phs_config_t]]
record, which can vary in concrete type.
<<Process config: public>>=
public :: process_phs_config_t
<<Process config: types>>=
type :: process_phs_config_t
type(phs_parameters_t) :: phs_par
type(mapping_defaults_t) :: mapping_defs
class(phs_config_t), allocatable :: phs_config
contains
<<Process config: process phs config: TBP>>
end type process_phs_config_t
@ %def process_phs_config_t
@ Output, DTIO compatible.
<<Process config: process phs config: TBP>>=
procedure :: write => process_phs_config_write
procedure :: write_formatted => process_phs_config_write_formatted
! generic :: write (formatted) => write_formatted
<<Process config: sub interfaces>>=
module subroutine process_phs_config_write (phs_config, unit)
class(process_phs_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
end subroutine process_phs_config_write
<<Process config: procedures>>=
module subroutine process_phs_config_write (phs_config, unit)
class(process_phs_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
integer :: u, iostat
integer, dimension(:), allocatable :: v_list
character(0) :: iomsg
u = given_output_unit (unit)
allocate (v_list (0))
call phs_config%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg)
end subroutine process_phs_config_write
@ %def process_phs_config_write
@ DTIO standard write.
<<Process config: sub interfaces>>=
module subroutine process_phs_config_write_formatted &
(dtv, unit, iotype, v_list, iostat, iomsg)
class(process_phs_config_t), intent(in) :: dtv
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, dimension(:), intent(in) :: v_list
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
end subroutine process_phs_config_write_formatted
<<Process config: procedures>>=
module subroutine process_phs_config_write_formatted &
(dtv, unit, iotype, v_list, iostat, iomsg)
class(process_phs_config_t), intent(in) :: dtv
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, dimension(:), intent(in) :: v_list
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
associate (phs_config => dtv)
write (unit, "(1x, A)") "Phase-space configuration entry:"
call phs_config%phs_par%write (unit)
call phs_config%mapping_defs%write (unit)
end associate
iostat = 0
end subroutine process_phs_config_write_formatted
@ %def process_phs_config_write_formatted
@
\subsection{Beam configuration}
The object [[data]] holds all details about the initial beam
configuration. The allocatable array [[sf]] holds the structure-function
configuration blocks. There are [[n_strfun]] entries in the
structure-function chain (not counting the initial beam object). We
maintain [[n_channel]] independent parameterizations of this chain.
If this is greater than zero, we need a multi-channel sampling
algorithm, where for each point one channel is selected to generate
kinematics.
The number of parameters that are required for generating a
structure-function chain is [[n_sfpar]].
The flag [[azimuthal_dependence]] tells whether the process setup is
symmetric about the beam axis in the c.m.\ system. This implies that
there is no transversal beam polarization. The flag [[lab_is_cm]] is
obvious.
<<Process config: public>>=
public :: process_beam_config_t
<<Process config: types>>=
type :: process_beam_config_t
type(beam_data_t) :: data
integer :: n_strfun = 0
integer :: n_channel = 1
integer :: n_sfpar = 0
type(sf_config_t), dimension(:), allocatable :: sf
type(sf_channel_t), dimension(:), allocatable :: sf_channel
logical :: azimuthal_dependence = .false.
logical :: lab_is_cm = .true.
character(32) :: md5sum = ""
logical :: sf_trace = .false.
type(string_t) :: sf_trace_file
contains
<<Process config: process beam config: TBP>>
end type process_beam_config_t
@ %def process_beam_config_t
@ Here we write beam data only if they are actually used.
The [[verbose]] flag is passed to the beam-data writer.
<<Process config: process beam config: TBP>>=
procedure :: write => process_beam_config_write
<<Process config: sub interfaces>>=
module subroutine process_beam_config_write (object, unit, verbose)
class(process_beam_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
end subroutine process_beam_config_write
<<Process config: procedures>>=
module subroutine process_beam_config_write (object, unit, verbose)
class(process_beam_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer :: u, i, c
u = given_output_unit (unit)
call object%data%write (u, verbose = verbose)
if (object%data%initialized) then
write (u, "(3x,A,L1)") "Azimuthal dependence = ", &
object%azimuthal_dependence
write (u, "(3x,A,L1)") "Lab frame is c.m. frame = ", &
object%lab_is_cm
if (object%md5sum /= "") then
write (u, "(3x,A,A,A)") "MD5 sum (beams/strf) = '", &
object%md5sum, "'"
end if
if (allocated (object%sf)) then
do i = 1, size (object%sf)
call object%sf(i)%write (u)
end do
if (any_sf_channel_has_mapping (object%sf_channel)) then
write (u, "(1x,A,L1)") "Structure-function mappings per channel:"
do c = 1, object%n_channel
write (u, "(3x,I0,':')", advance="no") c
call object%sf_channel(c)%write (u)
end do
end if
end if
end if
end subroutine process_beam_config_write
@ %def process_beam_config_write
@ The beam data have a finalizer. We assume that there is none for the
structure-function data.
<<Process config: process beam config: TBP>>=
procedure :: final => process_beam_config_final
<<Process config: sub interfaces>>=
module subroutine process_beam_config_final (object)
class(process_beam_config_t), intent(inout) :: object
end subroutine process_beam_config_final
<<Process config: procedures>>=
module subroutine process_beam_config_final (object)
class(process_beam_config_t), intent(inout) :: object
call object%data%final ()
end subroutine process_beam_config_final
@ %def process_beam_config_final
@ Initialize the beam setup with a given beam structure object.
<<Process config: process beam config: TBP>>=
procedure :: init_beam_structure => process_beam_config_init_beam_structure
<<Process config: sub interfaces>>=
module subroutine process_beam_config_init_beam_structure &
(beam_config, beam_structure, sqrts, model, decay_rest_frame)
class(process_beam_config_t), intent(out) :: beam_config
type(beam_structure_t), intent(in) :: beam_structure
logical, intent(in), optional :: decay_rest_frame
real(default), intent(in) :: sqrts
class(model_data_t), intent(in), target :: model
end subroutine process_beam_config_init_beam_structure
<<Process config: procedures>>=
module subroutine process_beam_config_init_beam_structure &
(beam_config, beam_structure, sqrts, model, decay_rest_frame)
class(process_beam_config_t), intent(out) :: beam_config
type(beam_structure_t), intent(in) :: beam_structure
logical, intent(in), optional :: decay_rest_frame
real(default), intent(in) :: sqrts
class(model_data_t), intent(in), target :: model
call beam_config%data%init_structure (beam_structure, &
sqrts, model, decay_rest_frame)
beam_config%lab_is_cm = beam_config%data%lab_is_cm
end subroutine process_beam_config_init_beam_structure
@ %def process_beam_config_init_beam_structure
@ Initialize the beam setup for a scattering process with specified
flavor combination, other properties taken from the beam structure
object (if any).
<<Process config: process beam config: TBP>>=
procedure :: init_scattering => process_beam_config_init_scattering
<<Process config: sub interfaces>>=
module subroutine process_beam_config_init_scattering &
(beam_config, flv_in, sqrts, beam_structure)
class(process_beam_config_t), intent(out) :: beam_config
type(flavor_t), dimension(2), intent(in) :: flv_in
real(default), intent(in) :: sqrts
type(beam_structure_t), intent(in), optional :: beam_structure
end subroutine process_beam_config_init_scattering
<<Process config: procedures>>=
module subroutine process_beam_config_init_scattering &
(beam_config, flv_in, sqrts, beam_structure)
class(process_beam_config_t), intent(out) :: beam_config
type(flavor_t), dimension(2), intent(in) :: flv_in
real(default), intent(in) :: sqrts
type(beam_structure_t), intent(in), optional :: beam_structure
if (present (beam_structure)) then
if (beam_structure%polarized ()) then
call beam_config%data%init_sqrts (sqrts, flv_in, &
beam_structure%get_smatrix (), beam_structure%get_pol_f ())
else
call beam_config%data%init_sqrts (sqrts, flv_in)
end if
else
call beam_config%data%init_sqrts (sqrts, flv_in)
end if
end subroutine process_beam_config_init_scattering
@ %def process_beam_config_init_scattering
@ Initialize the beam setup for a decay process with specified flavor,
other properties taken from the beam structure object (if present).
For a cascade decay, we set
[[rest_frame]] to false, indicating a event-wise varying momentum.
The beam data itself are initialized for the particle at rest.
<<Process config: process beam config: TBP>>=
procedure :: init_decay => process_beam_config_init_decay
<<Process config: sub interfaces>>=
module subroutine process_beam_config_init_decay &
(beam_config, flv_in, rest_frame, beam_structure)
class(process_beam_config_t), intent(out) :: beam_config
type(flavor_t), dimension(1), intent(in) :: flv_in
logical, intent(in), optional :: rest_frame
type(beam_structure_t), intent(in), optional :: beam_structure
end subroutine process_beam_config_init_decay
<<Process config: procedures>>=
module subroutine process_beam_config_init_decay &
(beam_config, flv_in, rest_frame, beam_structure)
class(process_beam_config_t), intent(out) :: beam_config
type(flavor_t), dimension(1), intent(in) :: flv_in
logical, intent(in), optional :: rest_frame
type(beam_structure_t), intent(in), optional :: beam_structure
if (present (beam_structure)) then
if (beam_structure%polarized ()) then
call beam_config%data%init_decay (flv_in, &
beam_structure%get_smatrix (), beam_structure%get_pol_f (), &
rest_frame = rest_frame)
else
call beam_config%data%init_decay (flv_in, rest_frame = rest_frame)
end if
else
call beam_config%data%init_decay (flv_in, &
rest_frame = rest_frame)
end if
beam_config%lab_is_cm = beam_config%data%lab_is_cm
end subroutine process_beam_config_init_decay
@ %def process_beam_config_init_decay
@ Print an informative message.
<<Process config: process beam config: TBP>>=
procedure :: startup_message => process_beam_config_startup_message
<<Process config: sub interfaces>>=
module subroutine process_beam_config_startup_message &
(beam_config, unit, beam_structure)
class(process_beam_config_t), intent(in) :: beam_config
integer, intent(in), optional :: unit
type(beam_structure_t), intent(in), optional :: beam_structure
end subroutine process_beam_config_startup_message
<<Process config: procedures>>=
module subroutine process_beam_config_startup_message &
(beam_config, unit, beam_structure)
class(process_beam_config_t), intent(in) :: beam_config
integer, intent(in), optional :: unit
type(beam_structure_t), intent(in), optional :: beam_structure
integer :: u
u = free_unit ()
open (u, status="scratch", action="readwrite")
if (present (beam_structure)) then
call beam_structure%write (u)
end if
call beam_config%data%write (u)
rewind (u)
do
read (u, "(1x,A)", end=1) msg_buffer
call msg_message ()
end do
1 continue
close (u)
end subroutine process_beam_config_startup_message
@ %def process_beam_config_startup_message
@ Allocate the structure-function array.
<<Process config: process beam config: TBP>>=
procedure :: init_sf_chain => process_beam_config_init_sf_chain
<<Process config: sub interfaces>>=
module subroutine process_beam_config_init_sf_chain &
(beam_config, sf_config, sf_trace_file)
class(process_beam_config_t), intent(inout) :: beam_config
type(sf_config_t), dimension(:), intent(in) :: sf_config
type(string_t), intent(in), optional :: sf_trace_file
end subroutine process_beam_config_init_sf_chain
<<Process config: procedures>>=
module subroutine process_beam_config_init_sf_chain &
(beam_config, sf_config, sf_trace_file)
class(process_beam_config_t), intent(inout) :: beam_config
type(sf_config_t), dimension(:), intent(in) :: sf_config
type(string_t), intent(in), optional :: sf_trace_file
integer :: i
beam_config%n_strfun = size (sf_config)
allocate (beam_config%sf (beam_config%n_strfun))
do i = 1, beam_config%n_strfun
associate (sf => sf_config(i))
call beam_config%sf(i)%init (sf%i, sf%data)
if (.not. sf%data%is_generator ()) then
beam_config%n_sfpar = beam_config%n_sfpar + sf%data%get_n_par ()
end if
end associate
end do
if (present (sf_trace_file)) then
beam_config%sf_trace = .true.
beam_config%sf_trace_file = sf_trace_file
end if
end subroutine process_beam_config_init_sf_chain
@ %def process_beam_config_init_sf_chain
@ Allocate the structure-function mapping channel array, given the
requested number of channels.
<<Process config: process beam config: TBP>>=
procedure :: allocate_sf_channels => process_beam_config_allocate_sf_channels
<<Process config: sub interfaces>>=
module subroutine process_beam_config_allocate_sf_channels &
(beam_config, n_channel)
class(process_beam_config_t), intent(inout) :: beam_config
integer, intent(in) :: n_channel
end subroutine process_beam_config_allocate_sf_channels
<<Process config: procedures>>=
module subroutine process_beam_config_allocate_sf_channels &
(beam_config, n_channel)
class(process_beam_config_t), intent(inout) :: beam_config
integer, intent(in) :: n_channel
beam_config%n_channel = n_channel
call allocate_sf_channels (beam_config%sf_channel, &
n_channel = n_channel, &
n_strfun = beam_config%n_strfun)
end subroutine process_beam_config_allocate_sf_channels
@ %def process_beam_config_allocate_sf_channels
@ Set a structure-function mapping channel for an array of
structure-function entries, for a single channel. (The default is no mapping.)
<<Process config: process beam config: TBP>>=
procedure :: set_sf_channel => process_beam_config_set_sf_channel
<<Process config: sub interfaces>>=
module subroutine process_beam_config_set_sf_channel &
(beam_config, c, sf_channel)
class(process_beam_config_t), intent(inout) :: beam_config
integer, intent(in) :: c
type(sf_channel_t), intent(in) :: sf_channel
end subroutine process_beam_config_set_sf_channel
<<Process config: procedures>>=
module subroutine process_beam_config_set_sf_channel &
(beam_config, c, sf_channel)
class(process_beam_config_t), intent(inout) :: beam_config
integer, intent(in) :: c
type(sf_channel_t), intent(in) :: sf_channel
beam_config%sf_channel(c) = sf_channel
end subroutine process_beam_config_set_sf_channel
@ %def process_beam_config_set_sf_channel
@ Print an informative startup message.
<<Process config: process beam config: TBP>>=
procedure :: sf_startup_message => process_beam_config_sf_startup_message
<<Process config: sub interfaces>>=
module subroutine process_beam_config_sf_startup_message &
(beam_config, sf_string, unit)
class(process_beam_config_t), intent(in) :: beam_config
type(string_t), intent(in) :: sf_string
integer, intent(in), optional :: unit
end subroutine process_beam_config_sf_startup_message
<<Process config: procedures>>=
module subroutine process_beam_config_sf_startup_message &
(beam_config, sf_string, unit)
class(process_beam_config_t), intent(in) :: beam_config
type(string_t), intent(in) :: sf_string
integer, intent(in), optional :: unit
if (beam_config%n_strfun > 0) then
call msg_message ("Beam structure: " // char (sf_string), unit = unit)
write (msg_buffer, "(A,3(1x,I0,1x,A))") &
"Beam structure:", &
beam_config%n_channel, "channels,", &
beam_config%n_sfpar, "dimensions"
call msg_message (unit = unit)
if (beam_config%sf_trace) then
call msg_message ("Beam structure: tracing &
&values in '" // char (beam_config%sf_trace_file) // "'")
end if
end if
end subroutine process_beam_config_sf_startup_message
@ %def process_beam_config_startup_message
@ Return the PDF set currently in use, if any. This should be unique,
so we scan the structure functions until we get a nonzero number.
(This implies that if the PDF set is not unique (e.g., proton and
photon structure used together), this does not work correctly.)
<<Process config: process beam config: TBP>>=
procedure :: get_pdf_set => process_beam_config_get_pdf_set
<<Process config: sub interfaces>>=
module function process_beam_config_get_pdf_set &
(beam_config) result (pdf_set)
class(process_beam_config_t), intent(in) :: beam_config
integer :: pdf_set
end function process_beam_config_get_pdf_set
<<Process config: procedures>>=
module function process_beam_config_get_pdf_set (beam_config) result (pdf_set)
class(process_beam_config_t), intent(in) :: beam_config
integer :: pdf_set
integer :: i
pdf_set = 0
if (allocated (beam_config%sf)) then
do i = 1, size (beam_config%sf)
pdf_set = beam_config%sf(i)%get_pdf_set ()
if (pdf_set /= 0) return
end do
end if
end function process_beam_config_get_pdf_set
@ %def process_beam_config_get_pdf_set
@ Return the beam file.
<<Process config: process beam config: TBP>>=
procedure :: get_beam_file => process_beam_config_get_beam_file
<<Process config: sub interfaces>>=
module function process_beam_config_get_beam_file &
(beam_config) result (file)
class(process_beam_config_t), intent(in) :: beam_config
type(string_t) :: file
end function process_beam_config_get_beam_file
<<Process config: procedures>>=
module function process_beam_config_get_beam_file (beam_config) result (file)
class(process_beam_config_t), intent(in) :: beam_config
type(string_t) :: file
integer :: i
file = ""
if (allocated (beam_config%sf)) then
do i = 1, size (beam_config%sf)
file = beam_config%sf(i)%get_beam_file ()
if (file /= "") return
end do
end if
end function process_beam_config_get_beam_file
@ %def process_beam_config_get_beam_file
@ Compute the MD5 sum for the complete beam setup. We rely on the
default output of [[write]] to contain all relevant data.
This is done only once, when the MD5 sum is still empty.
<<Process config: process beam config: TBP>>=
procedure :: compute_md5sum => process_beam_config_compute_md5sum
<<Process config: sub interfaces>>=
module subroutine process_beam_config_compute_md5sum (beam_config)
class(process_beam_config_t), intent(inout) :: beam_config
end subroutine process_beam_config_compute_md5sum
<<Process config: procedures>>=
module subroutine process_beam_config_compute_md5sum (beam_config)
class(process_beam_config_t), intent(inout) :: beam_config
integer :: u
if (beam_config%md5sum == "") then
u = free_unit ()
open (u, status = "scratch", action = "readwrite")
call beam_config%write (u, verbose=.true.)
rewind (u)
beam_config%md5sum = md5sum (u)
close (u)
end if
end subroutine process_beam_config_compute_md5sum
@ %def process_beam_config_compute_md5sum
@
<<Process config: process beam config: TBP>>=
procedure :: get_md5sum => process_beam_config_get_md5sum
<<Process config: sub interfaces>>=
pure module function process_beam_config_get_md5sum &
(beam_config) result (md5)
character(32) :: md5
class(process_beam_config_t), intent(in) :: beam_config
end function process_beam_config_get_md5sum
<<Process config: procedures>>=
pure module function process_beam_config_get_md5sum (beam_config) result (md5)
character(32) :: md5
class(process_beam_config_t), intent(in) :: beam_config
md5 = beam_config%md5sum
end function process_beam_config_get_md5sum
@ %def process_beam_config_get_md5sum
@
<<Process config: process beam config: TBP>>=
procedure :: has_structure_function => &
process_beam_config_has_structure_function
<<Process config: sub interfaces>>=
pure module function process_beam_config_has_structure_function &
(beam_config) result (has_sf)
logical :: has_sf
class(process_beam_config_t), intent(in) :: beam_config
end function process_beam_config_has_structure_function
<<Process config: procedures>>=
pure module function process_beam_config_has_structure_function &
(beam_config) result (has_sf)
logical :: has_sf
class(process_beam_config_t), intent(in) :: beam_config
has_sf = beam_config%n_strfun > 0
end function process_beam_config_has_structure_function
@ %def process_beam_config_has_structure_function
@
\subsection{Process components}
A process component is an individual contribution to a process
(scattering or decay) which needs not be physical. The sum over all
components should be physical.
The [[index]] indentifies this component within its parent process.
The actual process component is stored in the [[core]] subobject. We
use a polymorphic subobject instead of an extension of
[[process_component_t]], because the individual entries in the array
of process components can have different types. In short,
[[process_component_t]] is a wrapper for the actual process variants.
If the [[active]] flag is false, we should skip this component. This happens
if the associated process has vanishing matrix element.
The index array [[i_term]] points to the individual terms generated by
this component. The indices refer to the parent process.
The index [[i_mci]] is the index of the MC integrator and parameter set which
are associated to this process component.
<<Process config: public>>=
public :: process_component_t
<<Process config: types>>=
type :: process_component_t
type(process_component_def_t), pointer :: config => null ()
integer :: index = 0
logical :: active = .false.
integer, dimension(:), allocatable :: i_term
integer :: i_mci = 0
class(phs_config_t), allocatable :: phs_config
character(32) :: md5sum_phs = ""
integer :: component_type = COMP_DEFAULT
contains
<<Process config: process component: TBP>>
end type process_component_t
@ %def process_component_t
@ Finalizer. The MCI template may (potentially) need a finalizer. The process
configuration finalizer may include closing an open scratch file.
<<Process config: process component: TBP>>=
procedure :: final => process_component_final
<<Process config: sub interfaces>>=
module subroutine process_component_final (object)
class(process_component_t), intent(inout) :: object
end subroutine process_component_final
<<Process config: procedures>>=
module subroutine process_component_final (object)
class(process_component_t), intent(inout) :: object
if (allocated (object%phs_config)) then
call object%phs_config%final ()
end if
end subroutine process_component_final
@ %def process_component_final
@ The meaning of [[verbose]] depends on the process variant.
<<Process config: process component: TBP>>=
procedure :: write => process_component_write
<<Process config: sub interfaces>>=
module subroutine process_component_write (object, unit)
class(process_component_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine process_component_write
<<Process config: procedures>>=
module subroutine process_component_write (object, unit)
class(process_component_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
if (associated (object%config)) then
write (u, "(1x,A,I0)") "Component #", object%index
call object%config%write (u)
if (object%md5sum_phs /= "") then
write (u, "(3x,A,A,A)") "MD5 sum (phs) = '", &
object%md5sum_phs, "'"
end if
else
write (u, "(1x,A)") "Process component: [not allocated]"
end if
if (.not. object%active) then
write (u, "(1x,A)") "[Inactive]"
return
end if
write (u, "(1x,A)") "Referenced data:"
if (allocated (object%i_term)) then
write (u, "(3x,A,999(1x,I0))") "Terms =", &
object%i_term
else
write (u, "(3x,A)") "Terms = [undefined]"
end if
if (object%i_mci /= 0) then
write (u, "(3x,A,I0)") "MC dataset = ", object%i_mci
else
write (u, "(3x,A)") "MC dataset = [undefined]"
end if
if (allocated (object%phs_config)) then
call object%phs_config%write (u)
end if
end subroutine process_component_write
@ %def process_component_write
@ Initialize the component.
<<Process config: process component: TBP>>=
procedure :: init => process_component_init
<<Process config: sub interfaces>>=
module subroutine process_component_init (component, &
i_component, env, meta, config, &
active, &
phs_config_template)
class(process_component_t), intent(out) :: component
integer, intent(in) :: i_component
type(process_environment_t), intent(in) :: env
type(process_metadata_t), intent(in) :: meta
type(process_config_data_t), intent(in) :: config
logical, intent(in) :: active
class(phs_config_t), intent(in), allocatable :: phs_config_template
end subroutine process_component_init
<<Process config: procedures>>=
module subroutine process_component_init (component, &
i_component, env, meta, config, &
active, &
phs_config_template)
class(process_component_t), intent(out) :: component
integer, intent(in) :: i_component
type(process_environment_t), intent(in) :: env
type(process_metadata_t), intent(in) :: meta
type(process_config_data_t), intent(in) :: config
logical, intent(in) :: active
class(phs_config_t), intent(in), allocatable :: phs_config_template
type(process_constants_t) :: data
component%index = i_component
component%config => &
config%process_def%get_component_def_ptr (i_component)
component%active = active
if (component%active) then
allocate (component%phs_config, source = phs_config_template)
call env%fill_process_constants (meta%id, i_component, data)
call component%phs_config%init (data, config%model)
end if
end subroutine process_component_init
@ %def process_component_init
@
<<Process config: process component: TBP>>=
procedure :: is_active => process_component_is_active
<<Process config: sub interfaces>>=
elemental module function process_component_is_active &
(component) result (active)
logical :: active
class(process_component_t), intent(in) :: component
end function process_component_is_active
<<Process config: procedures>>=
elemental module function process_component_is_active &
(component) result (active)
logical :: active
class(process_component_t), intent(in) :: component
active = component%active
end function process_component_is_active
@ %def process_component_is_active
@ Finalize the phase-space configuration.
<<Process config: process component: TBP>>=
procedure :: configure_phs => process_component_configure_phs
<<Process config: sub interfaces>>=
module subroutine process_component_configure_phs &
(component, sqrts, beam_config, rebuild, &
ignore_mismatch, subdir)
class(process_component_t), intent(inout) :: component
real(default), intent(in) :: sqrts
type(process_beam_config_t), intent(in) :: beam_config
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
type(string_t), intent(in), optional :: subdir
end subroutine process_component_configure_phs
<<Process config: procedures>>=
module subroutine process_component_configure_phs &
(component, sqrts, beam_config, rebuild, &
ignore_mismatch, subdir)
class(process_component_t), intent(inout) :: component
real(default), intent(in) :: sqrts
type(process_beam_config_t), intent(in) :: beam_config
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
type(string_t), intent(in), optional :: subdir
logical :: no_strfun
integer :: nlo_type
no_strfun = beam_config%n_strfun == 0
nlo_type = component%config%get_nlo_type ()
call component%phs_config%configure (sqrts, &
azimuthal_dependence = beam_config%azimuthal_dependence, &
sqrts_fixed = no_strfun, &
lab_is_cm = beam_config%lab_is_cm .and. no_strfun, &
rebuild = rebuild, ignore_mismatch = ignore_mismatch, &
nlo_type = nlo_type, &
subdir = subdir)
end subroutine process_component_configure_phs
@ %def process_component_configure_phs
@ The process component possesses two MD5 sums: the checksum of the
component definition, which should be available when the component is
initialized, and the phase-space MD5 sum, which is available after
configuration.
<<Process config: process component: TBP>>=
procedure :: compute_md5sum => process_component_compute_md5sum
<<Process config: sub interfaces>>=
module subroutine process_component_compute_md5sum (component)
class(process_component_t), intent(inout) :: component
end subroutine process_component_compute_md5sum
<<Process config: procedures>>=
module subroutine process_component_compute_md5sum (component)
class(process_component_t), intent(inout) :: component
component%md5sum_phs = component%phs_config%get_md5sum ()
end subroutine process_component_compute_md5sum
@ %def process_component_compute_md5sum
@ Match phase-space channels with structure-function channels, where
applicable.
This calls a method of the [[phs_config]] phase-space implementation.
<<Process config: process component: TBP>>=
procedure :: collect_channels => process_component_collect_channels
<<Process config: sub interfaces>>=
module subroutine process_component_collect_channels (component, coll)
class(process_component_t), intent(inout) :: component
type(phs_channel_collection_t), intent(inout) :: coll
end subroutine process_component_collect_channels
<<Process config: procedures>>=
module subroutine process_component_collect_channels (component, coll)
class(process_component_t), intent(inout) :: component
type(phs_channel_collection_t), intent(inout) :: coll
call component%phs_config%collect_channels (coll)
end subroutine process_component_collect_channels
@ %def process_component_collect_channels
@
<<Process config: process component: TBP>>=
procedure :: get_config => process_component_get_config
<<Process config: sub interfaces>>=
module function process_component_get_config (component) &
result (config)
type(process_component_def_t) :: config
class(process_component_t), intent(in) :: component
end function process_component_get_config
<<Process config: procedures>>=
module function process_component_get_config (component) &
result (config)
type(process_component_def_t) :: config
class(process_component_t), intent(in) :: component
config = component%config
end function process_component_get_config
@ %def process_component_get_config
@
<<Process config: process component: TBP>>=
procedure :: get_md5sum => process_component_get_md5sum
<<Process config: sub interfaces>>=
pure module function process_component_get_md5sum (component) result (md5)
type(string_t) :: md5
class(process_component_t), intent(in) :: component
end function process_component_get_md5sum
<<Process config: procedures>>=
pure module function process_component_get_md5sum (component) result (md5)
type(string_t) :: md5
class(process_component_t), intent(in) :: component
md5 = component%config%get_md5sum () // component%md5sum_phs
end function process_component_get_md5sum
@ %def process_component_get_md5sum
@ Return the number of phase-space parameters.
<<Process config: process component: TBP>>=
procedure :: get_n_phs_par => process_component_get_n_phs_par
<<Process config: sub interfaces>>=
module function process_component_get_n_phs_par (component) result (n_par)
class(process_component_t), intent(in) :: component
integer :: n_par
end function process_component_get_n_phs_par
<<Process config: procedures>>=
module function process_component_get_n_phs_par (component) result (n_par)
class(process_component_t), intent(in) :: component
integer :: n_par
n_par = component%phs_config%get_n_par ()
end function process_component_get_n_phs_par
@ %def process_component_get_n_phs_par
@
<<Process config: process component: TBP>>=
procedure :: get_phs_config => process_component_get_phs_config
<<Process config: sub interfaces>>=
module subroutine process_component_get_phs_config (component, phs_config)
class(process_component_t), intent(in), target :: component
class(phs_config_t), intent(out), pointer :: phs_config
end subroutine process_component_get_phs_config
<<Process config: procedures>>=
module subroutine process_component_get_phs_config (component, phs_config)
class(process_component_t), intent(in), target :: component
class(phs_config_t), intent(out), pointer :: phs_config
phs_config => component%phs_config
end subroutine process_component_get_phs_config
@ %def process_component_get_phs_config
@
<<Process config: process component: TBP>>=
procedure :: get_nlo_type => process_component_get_nlo_type
<<Process config: sub interfaces>>=
elemental module function process_component_get_nlo_type &
(component) result (nlo_type)
integer :: nlo_type
class(process_component_t), intent(in) :: component
end function process_component_get_nlo_type
<<Process config: procedures>>=
elemental module function process_component_get_nlo_type &
(component) result (nlo_type)
integer :: nlo_type
class(process_component_t), intent(in) :: component
nlo_type = component%config%get_nlo_type ()
end function process_component_get_nlo_type
@ %def process_component_get_nlo_type
@
<<Process config: process component: TBP>>=
procedure :: needs_mci_entry => process_component_needs_mci_entry
<<Process config: sub interfaces>>=
module function process_component_needs_mci_entry &
(component, combined_integration) result (value)
logical :: value
class(process_component_t), intent(in) :: component
logical, intent(in), optional :: combined_integration
end function process_component_needs_mci_entry
<<Process config: procedures>>=
module function process_component_needs_mci_entry &
(component, combined_integration) result (value)
logical :: value
class(process_component_t), intent(in) :: component
logical, intent(in), optional :: combined_integration
value = component%active
if (present (combined_integration)) then
if (combined_integration) &
value = value .and. component%component_type <= COMP_MASTER
end if
end function process_component_needs_mci_entry
@ %def process_component_needs_mci_entry
@
<<Process config: process component: TBP>>=
procedure :: can_be_integrated => process_component_can_be_integrated
<<Process config: sub interfaces>>=
elemental module function process_component_can_be_integrated &
(component) result (active)
logical :: active
class(process_component_t), intent(in) :: component
end function process_component_can_be_integrated
<<Process config: procedures>>=
elemental module function process_component_can_be_integrated &
(component) result (active)
logical :: active
class(process_component_t), intent(in) :: component
active = component%config%can_be_integrated ()
end function process_component_can_be_integrated
@ %def process_component_can_be_integrated
@
\subsection{Process terms}
For straightforward tree-level calculations, each process component
corresponds to a unique elementary interaction. However, in the case
of NLO calculations with subtraction terms, a process component may
split into several separate contributions to the scattering, which are
qualified by interactions with distinct kinematics and particle
content. We represent their configuration as [[process_term_t]]
objects, the actual instances will be introduced below as
[[term_instance_t]]. In any case, the process term contains an
elementary interaction with a definite quantum-number and momentum
content.
The index [[i_term_global]] identifies the term relative to the
process.
The index [[i_component]] identifies the process component which
generates this term, relative to the parent process.
The index [[i_term]] identifies the term relative to the process
component (not the process).
The [[data]] subobject holds all process constants.
The number of allowed flavor/helicity/color combinations is stored as
[[n_allowed]]. This is the total number of independent entries in the
density matrix. For each combination, the index of the flavor,
helicity, and color state is stored in the arrays [[flv]], [[hel]],
and [[col]], respectively.
The flag [[rearrange]] is true if we need to rearrange the particles of the
hard interaction, to obtain the effective parton state.
The interaction [[int]] holds the quantum state for the (resolved) hard
interaction, the parent-child relations of the particles, and their momenta.
The momenta are not filled yet; this is postponed to copies of [[int]] which
go into the process instances.
If recombination is in effect, we should allocate [[int_eff]] to describe the
rearranged partonic state.
This type is public only for use in a unit test.
<<Process config: public>>=
public :: process_term_t
<<Process config: types>>=
type :: process_term_t
integer :: i_term_global = 0
integer :: i_component = 0
integer :: i_term = 0
integer :: i_sub = 0
integer :: i_core = 0
integer :: n_allowed = 0
type(process_constants_t) :: data
real(default) :: alpha_s = 0
integer, dimension(:), allocatable :: flv, hel, col
integer :: n_sub, n_sub_color, n_sub_spin
type(interaction_t) :: int
type(interaction_t), pointer :: int_eff => null ()
contains
<<Process config: process term: TBP>>
end type process_term_t
@ %def process_term_t
@ For the output, we skip the process constants and the tables of
allowed quantum numbers. Those can also be read off from the
interaction object.
<<Process config: process term: TBP>>=
procedure :: write => process_term_write
<<Process config: sub interfaces>>=
module subroutine process_term_write (term, unit)
class(process_term_t), intent(in) :: term
integer, intent(in), optional :: unit
end subroutine process_term_write
<<Process config: procedures>>=
module subroutine process_term_write (term, unit)
class(process_term_t), intent(in) :: term
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A,I0)") "Term #", term%i_term_global
write (u, "(3x,A,I0)") "Process component index = ", &
term%i_component
write (u, "(3x,A,I0)") "Term index w.r.t. component = ", &
term%i_term
call write_separator (u)
write (u, "(1x,A)") "Hard interaction:"
call write_separator (u)
call term%int%basic_write (u)
end subroutine process_term_write
@ %def process_term_write
@ Write an account of all quantum number states and their current status.
<<Process config: process term: TBP>>=
procedure :: write_state_summary => process_term_write_state_summary
<<Process config: sub interfaces>>=
module subroutine process_term_write_state_summary (term, core, unit)
class(process_term_t), intent(in) :: term
class(prc_core_t), intent(in) :: core
integer, intent(in), optional :: unit
end subroutine process_term_write_state_summary
<<Process config: procedures>>=
module subroutine process_term_write_state_summary (term, core, unit)
class(process_term_t), intent(in) :: term
class(prc_core_t), intent(in) :: core
integer, intent(in), optional :: unit
integer :: u, i, f, h, c
type(state_iterator_t) :: it
character :: sgn
u = given_output_unit (unit)
write (u, "(1x,A,I0)") "Term #", term%i_term_global
call it%init (term%int%get_state_matrix_ptr ())
do while (it%is_valid ())
i = it%get_me_index ()
f = term%flv(i)
h = term%hel(i)
if (allocated (term%col)) then
c = term%col(i)
else
c = 1
end if
if (core%is_allowed (term%i_term, f, h, c)) then
sgn = "+"
else
sgn = " "
end if
write (u, "(1x,A1,1x,I0,2x)", advance="no") sgn, i
call quantum_numbers_write (it%get_quantum_numbers (), u)
write (u, *)
call it%advance ()
end do
end subroutine process_term_write_state_summary
@ %def process_term_write_state_summary
@ Finalizer: the [[int]] and potentially [[int_eff]] components have a
finalizer that we must call.
<<Process config: process term: TBP>>=
procedure :: final => process_term_final
<<Process config: sub interfaces>>=
module subroutine process_term_final (term)
class(process_term_t), intent(inout) :: term
end subroutine process_term_final
<<Process config: procedures>>=
module subroutine process_term_final (term)
class(process_term_t), intent(inout) :: term
call term%int%final ()
end subroutine process_term_final
@ %def process_term_final
@ Initialize the term. We copy the process constants from the [[core]]
object and set up the [[int]] hard interaction accordingly.
The [[alpha_s]] value is useful for writing external event records. This is
the constant value which may be overridden by an event-specific running value.
If the model does not contain the strong coupling, the value is zero.
The [[rearrange]] part is commented out; this or something equivalent
could become relevant for NLO algorithms.
<<Process config: process term: TBP>>=
procedure :: init => process_term_init
<<Process config: sub interfaces>>=
module subroutine process_term_init &
(term, i_term_global, i_component, i_term, core, model, &
nlo_type, use_beam_pol, subtraction_method, &
has_pdfs, n_emitters)
class(process_term_t), intent(inout), target :: term
integer, intent(in) :: i_term_global
integer, intent(in) :: i_component
integer, intent(in) :: i_term
class(prc_core_t), intent(inout) :: core
class(model_data_t), intent(in), target :: model
integer, intent(in), optional :: nlo_type
logical, intent(in), optional :: use_beam_pol
type(string_t), intent(in), optional :: subtraction_method
logical, intent(in), optional :: has_pdfs
integer, intent(in), optional :: n_emitters
end subroutine process_term_init
<<Process config: procedures>>=
module subroutine process_term_init &
(term, i_term_global, i_component, i_term, core, model, &
nlo_type, use_beam_pol, subtraction_method, &
has_pdfs, n_emitters)
class(process_term_t), intent(inout), target :: term
integer, intent(in) :: i_term_global
integer, intent(in) :: i_component
integer, intent(in) :: i_term
class(prc_core_t), intent(inout) :: core
class(model_data_t), intent(in), target :: model
integer, intent(in), optional :: nlo_type
logical, intent(in), optional :: use_beam_pol
type(string_t), intent(in), optional :: subtraction_method
logical, intent(in), optional :: has_pdfs
integer, intent(in), optional :: n_emitters
class(modelpar_data_t), pointer :: alpha_s_ptr
logical :: use_internal_color
term%i_term_global = i_term_global
term%i_component = i_component
term%i_term = i_term
call core%get_constants (term%data, i_term)
alpha_s_ptr => model%get_par_data_ptr (var_str ("alphas"))
if (associated (alpha_s_ptr)) then
term%alpha_s = alpha_s_ptr%get_real ()
else
term%alpha_s = -1
end if
use_internal_color = .false.
if (present (subtraction_method)) &
use_internal_color = (char (subtraction_method) == 'omega') &
.or. (char (subtraction_method) == 'threshold')
call term%setup_interaction (core, model, nlo_type = nlo_type, &
pol_beams = use_beam_pol, use_internal_color = use_internal_color, &
has_pdfs = has_pdfs, n_emitters = n_emitters)
end subroutine process_term_init
@ %def process_term_init
@ We fetch the process constants which determine the quantum numbers and
use those to create the interaction. The interaction contains
incoming and outgoing particles, no virtuals. The incoming particles
are parents of the outgoing ones.
Keeping previous \whizard\ conventions, we invert the color assignment
(but not flavor or helicity) for the incoming particles. When the
color-flow square matrix is evaluated, this inversion is done again,
so in the color-flow sequence we get the color assignments of the
matrix element.
\textbf{Why are these four subtraction entries for structure-function
aware interactions?} Taking the soft or collinear limit of the real-emission
matrix element, the behavior of the parton energy fractions has to be
taken into account. In the pure real case, $x_\oplus$ and $x_\ominus$
are given by
\begin{equation*}
x_\oplus = \frac{\bar{x}_\oplus}{\sqrt{1-\xi}}
\sqrt{\frac{2 - \xi(1-y)}{2 - \xi(1+y)}},
\quad
x_\ominus = \frac{\bar{x}_\ominus}{\sqrt{1-\xi}}
\sqrt{\frac{2 - \xi(1+y)}{2 - \xi(1-y)}}.
\end{equation*}
In the soft limit, $\xi \to 0$, this yields $x_\oplus = \bar{x}_\oplus$
and $x_\ominus = \bar{x}_\ominus$. In the collinear limit, $y \to 1$,
it is $x_\oplus = \bar{x}_\oplus / (1 - \xi)$ and $x_\ominus = \bar{x}_\ominus$.
Likewise, in the anti-collinear limit $y \to -1$, the inverse relation holds.
We therefore have to distinguish four cases with the PDF assignments
$f(x_\oplus) \cdot f(x_\ominus)$, $f(\bar{x}_\oplus) \cdot f(\bar{x}_\ominus)$,
$f\left(\bar{x}_\oplus / (1-\xi)\right) \cdot f(\bar{x}_\ominus)$ and
$f(\bar{x}_\oplus) \cdot f\left(\bar{x}_\ominus / (1-\xi)\right)$.
The [[n_emitters]] optional argument is provided by the caller if this term
requires spin-correlated matrix elements, and thus involves additional
subtractions.
<<Process config: process term: TBP>>=
procedure :: setup_interaction => process_term_setup_interaction
<<Process config: sub interfaces>>=
module subroutine process_term_setup_interaction (term, core, model, &
nlo_type, pol_beams, has_pdfs, use_internal_color, n_emitters)
class(process_term_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
class(model_data_t), intent(in), target :: model
logical, intent(in), optional :: pol_beams
logical, intent(in), optional :: has_pdfs
integer, intent(in), optional :: nlo_type
logical, intent(in), optional :: use_internal_color
integer, intent(in), optional :: n_emitters
end subroutine process_term_setup_interaction
<<Process config: procedures>>=
module subroutine process_term_setup_interaction (term, core, model, &
nlo_type, pol_beams, has_pdfs, use_internal_color, n_emitters)
class(process_term_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
class(model_data_t), intent(in), target :: model
logical, intent(in), optional :: pol_beams
logical, intent(in), optional :: has_pdfs
integer, intent(in), optional :: nlo_type
logical, intent(in), optional :: use_internal_color
integer, intent(in), optional :: n_emitters
integer :: n, n_tot
type(flavor_t), dimension(:), allocatable :: flv
type(color_t), dimension(:), allocatable :: col
type(helicity_t), dimension(:), allocatable :: hel
type(quantum_numbers_t), dimension(:), allocatable :: qn
logical :: is_pol, use_color
integer :: nlo_t, n_sub
is_pol = .false.; if (present (pol_beams)) is_pol = pol_beams
nlo_t = BORN; if (present (nlo_type)) nlo_t = nlo_type
n_tot = term%data%n_in + term%data%n_out
call count_number_of_states ()
term%n_allowed = n
call compute_n_sub (n_emitters, has_pdfs)
call fill_quantum_numbers ()
call term%int%basic_init &
(term%data%n_in, 0, term%data%n_out, set_relations = .true.)
select type (core)
class is (prc_blha_t)
call setup_states_blha_olp ()
type is (prc_threshold_t)
call setup_states_threshold ()
class is (prc_external_t)
call setup_states_other_prc_external ()
class default
call setup_states_omega ()
end select
call term%int%freeze ()
contains
subroutine count_number_of_states ()
integer :: f, h, c
n = 0
select type (core)
class is (prc_external_t)
do f = 1, term%data%n_flv
do h = 1, term%data%n_hel
do c = 1, term%data%n_col
n = n + 1
end do
end do
end do
class default !!! Omega and all test cores
do f = 1, term%data%n_flv
do h = 1, term%data%n_hel
do c = 1, term%data%n_col
if (core%is_allowed (term%i_term, f, h, c)) n = n + 1
end do
end do
end do
end select
end subroutine count_number_of_states
subroutine compute_n_sub (n_emitters, has_pdfs)
integer, intent(in), optional :: n_emitters
logical, intent(in), optional :: has_pdfs
logical :: can_have_sub
integer :: n_sub_color, n_sub_spin
use_color = .false.; if (present (use_internal_color)) &
use_color = use_internal_color
can_have_sub = nlo_t == NLO_VIRTUAL .or. &
(nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. &
nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP
n_sub_color = 0; n_sub_spin = 0
if (can_have_sub) then
if (.not. use_color) n_sub_color = n_tot * (n_tot - 1) / 2
if (nlo_t == NLO_REAL) then
if (present (n_emitters)) then
n_sub_spin = 6 * n_emitters
end if
end if
end if
n_sub = n_sub_color + n_sub_spin
!!! For the virtual subtraction we also need the finite virtual contribution
!!! corresponding to the $\epsilon^0$-pole
if (nlo_t == NLO_VIRTUAL) n_sub = n_sub + 1
if (present (has_pdfs)) then
if (has_pdfs &
.and. ((nlo_t == NLO_REAL .and. can_have_sub) &
.or. nlo_t == NLO_DGLAP)) then
!!! necessary dummy, needs refactoring,
!!! c.f. [[term_instance_evaluate_interaction_external_tree]]
n_sub = n_sub + n_beams_rescaled
end if
end if
term%n_sub = n_sub
term%n_sub_color = n_sub_color
term%n_sub_spin = n_sub_spin
end subroutine compute_n_sub
subroutine fill_quantum_numbers ()
integer :: nn
logical :: can_have_sub
select type (core)
class is (prc_external_t)
can_have_sub = nlo_t == NLO_VIRTUAL .or. &
(nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. &
nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP
if (can_have_sub) then
nn = (n_sub + 1) * n
else
nn = n
end if
class default
nn = n
end select
allocate (term%flv (nn), term%col (nn), term%hel (nn))
allocate (flv (n_tot), col (n_tot), hel (n_tot))
allocate (qn (n_tot))
end subroutine fill_quantum_numbers
subroutine setup_states_blha_olp ()
integer :: s, f, c, h, i
i = 0
associate (data => term%data)
do s = 0, n_sub
do f = 1, data%n_flv
do h = 1, data%n_hel
do c = 1, data%n_col
i = i + 1
term%flv(i) = f
term%hel(i) = h
!!! Dummy-initialization of color
term%col(i) = c
call flv%init (data%flv_state (:,f), model)
call color_init_from_array (col, &
data%col_state(:,:,c), data%ghost_flag(:,c))
call col(1:data%n_in)%invert ()
if (is_pol) then
select type (core)
type is (prc_openloops_t)
call hel%init (data%hel_state (:,h))
call qn%init (flv, hel, col, s)
class default
call msg_fatal ("Polarized beams only supported by OpenLoops")
end select
else
call qn%init (flv, col, s)
end if
call qn%tag_hard_process ()
call term%int%add_state (qn)
end do
end do
end do
end do
end associate
end subroutine setup_states_blha_olp
subroutine setup_states_threshold ()
integer :: s, f, c, h, i
i = 0
n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1
associate (data => term%data)
do s = 0, n_sub
do f = 1, term%data%n_flv
do h = 1, data%n_hel
do c = 1, data%n_col
i = i + 1
term%flv(i) = f
term%hel(i) = h
!!! Dummy-initialization of color
term%col(i) = 1
call flv%init (term%data%flv_state (:,f), model)
if (is_pol) then
call hel%init (data%hel_state (:,h))
call qn%init (flv, hel, s)
else
call qn%init (flv, s)
end if
call qn%tag_hard_process ()
call term%int%add_state (qn)
end do
end do
end do
end do
end associate
end subroutine setup_states_threshold
subroutine setup_states_other_prc_external ()
integer :: s, f, i, c, h
if (is_pol) &
call msg_fatal ("Polarized beams only supported by OpenLoops")
i = 0
!!! n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1
associate (data => term%data)
do s = 0, n_sub
do f = 1, data%n_flv
do h = 1, data%n_hel
do c = 1, data%n_col
i = i + 1
term%flv(i) = f
term%hel(i) = h
!!! Dummy-initialization of color
term%col(i) = c
call flv%init (data%flv_state (:,f), model)
call color_init_from_array (col, &
data%col_state(:,:,c), data%ghost_flag(:,c))
call col(1:data%n_in)%invert ()
call qn%init (flv, col, s)
call qn%tag_hard_process ()
call term%int%add_state (qn)
end do
end do
end do
end do
end associate
end subroutine setup_states_other_prc_external
subroutine setup_states_omega ()
integer :: f, h, c, i
i = 0
associate (data => term%data)
do f = 1, data%n_flv
do h = 1, data%n_hel
do c = 1, data%n_col
if (core%is_allowed (term%i_term, f, h, c)) then
i = i + 1
term%flv(i) = f
term%hel(i) = h
term%col(i) = c
call flv%init (data%flv_state(:,f), model)
call color_init_from_array (col, &
data%col_state(:,:,c), &
data%ghost_flag(:,c))
call col(:data%n_in)%invert ()
call hel%init (data%hel_state(:,h))
call qn%init (flv, col, hel)
call qn%tag_hard_process ()
call term%int%add_state (qn)
end if
end do
end do
end do
end associate
end subroutine setup_states_omega
end subroutine process_term_setup_interaction
@ %def process_term_setup_interaction
@
<<Process config: process term: TBP>>=
procedure :: get_process_constants => process_term_get_process_constants
<<Process config: sub interfaces>>=
module subroutine process_term_get_process_constants &
(term, prc_constants)
class(process_term_t), intent(inout) :: term
type(process_constants_t), intent(out) :: prc_constants
end subroutine process_term_get_process_constants
<<Process config: procedures>>=
module subroutine process_term_get_process_constants &
(term, prc_constants)
class(process_term_t), intent(inout) :: term
type(process_constants_t), intent(out) :: prc_constants
prc_constants = term%data
end subroutine process_term_get_process_constants
@ %def process_term_get_process_constants
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Process call statistics}
Very simple object for statistics. Could be moved to a more basic chapter.
<<[[process_counter.f90]]>>=
<<File header>>
module process_counter
<<Standard module head>>
<<Process counter: public>>
<<Process counter: parameters>>
<<Process counter: types>>
interface
<<Process counter: sub interfaces>>
end interface
end module process_counter
@ %def process_counter
@ This object can record process calls, categorized by evaluation
status. It is a part of the [[mci_entry]] component below.
<<Process counter: public>>=
public :: process_counter_t
<<Process counter: types>>=
type :: process_counter_t
integer :: total = 0
integer :: failed_kinematics = 0
integer :: failed_cuts = 0
integer :: has_passed = 0
integer :: evaluated = 0
integer :: complete = 0
contains
<<Process counter: process counter: TBP>>
end type process_counter_t
@ %def process_counter_t
@ Here are the corresponding numeric codes:
<<Process counter: parameters>>=
integer, parameter, public :: STAT_UNDEFINED = 0
integer, parameter, public :: STAT_INITIAL = 1
integer, parameter, public :: STAT_ACTIVATED = 2
integer, parameter, public :: STAT_BEAM_MOMENTA = 3
integer, parameter, public :: STAT_FAILED_KINEMATICS = 4
integer, parameter, public :: STAT_SEED_KINEMATICS = 5
integer, parameter, public :: STAT_HARD_KINEMATICS = 6
integer, parameter, public :: STAT_EFF_KINEMATICS = 7
integer, parameter, public :: STAT_FAILED_CUTS = 8
integer, parameter, public :: STAT_PASSED_CUTS = 9
integer, parameter, public :: STAT_EVALUATED_TRACE = 10
integer, parameter, public :: STAT_EVENT_COMPLETE = 11
@ %def STAT_UNDEFINED STAT_INITIAL STAT_ACTIVATED
@ %def STAT_BEAM_MOMENTA STAT_FAILED_KINEMATICS
@ %def STAT_SEED_KINEMATICS STAT_HARD_KINEMATICS STAT_EFF_KINEMATICS
@ %def STAT_EVALUATED_TRACE STAT_EVENT_COMPLETE
@ Output.
<<Process counter: process counter: TBP>>=
procedure :: write => process_counter_write
<<Process counter: sub interfaces>>=
module subroutine process_counter_write (object, unit)
class(process_counter_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine process_counter_write
<<Process counter: procedures>>=
module subroutine process_counter_write (object, unit)
class(process_counter_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
if (object%total > 0) then
write (u, "(1x,A)") "Call statistics (current run):"
write (u, "(3x,A,I0)") "total = ", object%total
write (u, "(3x,A,I0)") "failed kin. = ", object%failed_kinematics
write (u, "(3x,A,I0)") "failed cuts = ", object%failed_cuts
write (u, "(3x,A,I0)") "passed cuts = ", object%has_passed
write (u, "(3x,A,I0)") "evaluated = ", object%evaluated
else
write (u, "(1x,A)") "Call statistics (current run): [no calls]"
end if
end subroutine process_counter_write
@ %def process_counter_write
@
<<[[process_counter_sub.f90]]>>=
<<File header>>
submodule (process_counter) process_counter_s
use io_units
implicit none
contains
<<Process counter: procedures>>
end submodule process_counter_s
@ %def process_counter_s
@ Reset. Just enforce default initialization.
<<Process counter: process counter: TBP>>=
procedure :: reset => process_counter_reset
<<Process counter: sub interfaces>>=
module subroutine process_counter_reset (counter)
class(process_counter_t), intent(out) :: counter
end subroutine process_counter_reset
<<Process counter: procedures>>=
module subroutine process_counter_reset (counter)
class(process_counter_t), intent(out) :: counter
counter%total = 0
counter%failed_kinematics = 0
counter%failed_cuts = 0
counter%has_passed = 0
counter%evaluated = 0
counter%complete = 0
end subroutine process_counter_reset
@ %def process_counter_reset
@ We record an event according to the lowest status code greater or
equal to the actual status. This is actually done by the process
instance; the process object just copies the instance counter.
<<Process counter: process counter: TBP>>=
procedure :: record => process_counter_record
<<Process counter: sub interfaces>>=
module subroutine process_counter_record (counter, status)
class(process_counter_t), intent(inout) :: counter
integer, intent(in) :: status
end subroutine process_counter_record
<<Process counter: procedures>>=
module subroutine process_counter_record (counter, status)
class(process_counter_t), intent(inout) :: counter
integer, intent(in) :: status
if (status <= STAT_FAILED_KINEMATICS) then
counter%failed_kinematics = counter%failed_kinematics + 1
else if (status <= STAT_FAILED_CUTS) then
counter%failed_cuts = counter%failed_cuts + 1
else if (status <= STAT_PASSED_CUTS) then
counter%has_passed = counter%has_passed + 1
else
counter%evaluated = counter%evaluated + 1
end if
counter%total = counter%total + 1
end subroutine process_counter_record
@ %def process_counter_record
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Multi-channel integration}
<<[[process_mci.f90]]>>=
<<File header>>
module process_mci
<<Use kinds>>
<<Use strings>>
use cputime
use rng_base
use mci_base
use variables
use integration_results
use process_libraries
use phs_base
use process_counter
use process_config
<<Standard module head>>
<<Process mci: public>>
<<Process mci: parameters>>
<<Process mci: types>>
interface
<<Process mci: sub interfaces>>
end interface
end module process_mci
@ %def process_mci
@
<<[[process_mci_sub.f90]]>>=
<<File header>>
submodule (process_mci) process_mci_s
<<Use debug>>
use io_units
use diagnostics
use physics_defs
use md5
implicit none
contains
<<Process mci: procedures>>
end submodule process_mci_s
@ %def process_mci_s
\subsection{Process MCI entry}
The [[process_mci_entry_t]] block contains, for each process component that is
integrated independently, the configuration data for its MC input parameters.
Each input parameter set is handled by a [[mci_t]] integrator.
The MC input parameter set is broken down into the parameters required by the
structure-function chain and the parameters required by the phase space of the
elementary process.
The MD5 sum collects all information about the associated processes
that may affect the integration. It does not contain the MCI object
itself or integration results.
MC integration is organized in passes. Each pass may consist of
several iterations, and for each iteration there is a number of
calls. We store explicitly the values that apply to the current
pass. Previous values are archived in the [[results]] object.
The [[counter]] receives the counter statistics from the associated
process instance, for diagnostics.
The [[results]] object records results, broken down in passes and iterations.
<<Process mci: public>>=
public :: process_mci_entry_t
<<Process mci: types>>=
type :: process_mci_entry_t
integer :: i_mci = 0
integer, dimension(:), allocatable :: i_component
integer :: process_type = PRC_UNKNOWN
integer :: n_par = 0
integer :: n_par_sf = 0
integer :: n_par_phs = 0
character(32) :: md5sum = ""
integer :: pass = 0
integer :: n_it = 0
integer :: n_calls = 0
logical :: activate_timer = .false.
real(default) :: error_threshold = 0
class(mci_t), allocatable :: mci
type(process_counter_t) :: counter
type(integration_results_t) :: results
logical :: negative_weights = .false.
logical :: combined_integration = .false.
integer :: real_partition_type = REAL_FULL
contains
<<Process mci: process mci entry: TBP>>
end type process_mci_entry_t
@ %def process_mci_entry_t
@ Finalizer for the [[mci]] component.
<<Process mci: process mci entry: TBP>>=
procedure :: final => process_mci_entry_final
<<Process mci: sub interfaces>>=
module subroutine process_mci_entry_final (object)
class(process_mci_entry_t), intent(inout) :: object
end subroutine process_mci_entry_final
<<Process mci: procedures>>=
module subroutine process_mci_entry_final (object)
class(process_mci_entry_t), intent(inout) :: object
if (allocated (object%mci)) call object%mci%final ()
end subroutine process_mci_entry_final
@ %def process_mci_entry_final
@ Output. Write pass/iteration information only if set (the pass
index is nonzero). Write the MCI block only if it exists (for some
self-tests it does not). Write results only if there are any.
<<Process mci: process mci entry: TBP>>=
procedure :: write => process_mci_entry_write
<<Process mci: sub interfaces>>=
module subroutine process_mci_entry_write (object, unit, pacify)
class(process_mci_entry_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacify
end subroutine process_mci_entry_write
<<Process mci: procedures>>=
module subroutine process_mci_entry_write (object, unit, pacify)
class(process_mci_entry_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacify
integer :: u
u = given_output_unit (unit)
write (u, "(3x,A,I0)") "Associated components = ", object%i_component
write (u, "(3x,A,I0)") "MC input parameters = ", object%n_par
write (u, "(3x,A,I0)") "MC parameters (SF) = ", object%n_par_sf
write (u, "(3x,A,I0)") "MC parameters (PHS) = ", object%n_par_phs
if (object%pass > 0) then
write (u, "(3x,A,I0)") "Current pass = ", object%pass
write (u, "(3x,A,I0)") "Number of iterations = ", object%n_it
write (u, "(3x,A,I0)") "Number of calls = ", object%n_calls
end if
if (object%md5sum /= "") then
write (u, "(3x,A,A,A)") "MD5 sum (components) = '", object%md5sum, "'"
end if
if (allocated (object%mci)) then
call object%mci%write (u)
end if
call object%counter%write (u)
if (object%results%exist ()) then
call object%results%write (u, suppress = pacify)
call object%results%write_chain_weights (u)
end if
end subroutine process_mci_entry_write
@ %def process_mci_entry_write
@ Configure the MCI entry. This is intent(inout) since some specific settings
may be done before this. The actual [[mci_t]] object is an instance of the
[[mci_template]] argument, which determines the concrete types.
In a unit-test context, the [[mci_template]] argument may be unallocated.
We obtain the number of channels and the number of parameters separately for
the structure-function chain and for the associated process component. We
assume that the phase-space object has already been configured.
We assume that there is only one process component directly associated with an
MCI entry.
<<Process mci: process mci entry: TBP>>=
procedure :: configure => process_mci_entry_configure
<<Process mci: sub interfaces>>=
module subroutine process_mci_entry_configure (mci_entry, mci_template, &
process_type, i_mci, i_component, component, &
n_sfpar, rng_factory)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_t), intent(in), allocatable :: mci_template
integer, intent(in) :: process_type
integer, intent(in) :: i_mci
integer, intent(in) :: i_component
type(process_component_t), intent(in), target :: component
integer, intent(in) :: n_sfpar
class(rng_factory_t), intent(inout) :: rng_factory
end subroutine process_mci_entry_configure
<<Process mci: procedures>>=
module subroutine process_mci_entry_configure (mci_entry, mci_template, &
process_type, i_mci, i_component, component, &
n_sfpar, rng_factory)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_t), intent(in), allocatable :: mci_template
integer, intent(in) :: process_type
integer, intent(in) :: i_mci
integer, intent(in) :: i_component
type(process_component_t), intent(in), target :: component
integer, intent(in) :: n_sfpar
class(rng_factory_t), intent(inout) :: rng_factory
class(rng_t), allocatable :: rng
associate (phs_config => component%phs_config)
mci_entry%i_mci = i_mci
call mci_entry%create_component_list (i_component, component%get_config ())
mci_entry%n_par_sf = n_sfpar
mci_entry%n_par_phs = phs_config%get_n_par ()
mci_entry%n_par = mci_entry%n_par_sf + mci_entry%n_par_phs
mci_entry%process_type = process_type
if (allocated (mci_template)) then
allocate (mci_entry%mci, source = mci_template)
call mci_entry%mci%record_index (mci_entry%i_mci)
call mci_entry%mci%set_dimensions &
(mci_entry%n_par, phs_config%get_n_channel ())
call mci_entry%mci%declare_flat_dimensions &
(phs_config%get_flat_dimensions ())
if (phs_config%provides_equivalences) then
call mci_entry%mci%declare_equivalences &
(phs_config%channel, mci_entry%n_par_sf)
end if
if (phs_config%provides_chains) then
call mci_entry%mci%declare_chains (phs_config%chain)
end if
call rng_factory%make (rng)
call mci_entry%mci%import_rng (rng)
end if
call mci_entry%results%init (process_type)
end associate
end subroutine process_mci_entry_configure
@ %def process_mci_entry_configure
@
<<Process mci: parameters>>=
integer, parameter, public :: REAL_FULL = 0
integer, parameter, public :: REAL_SINGULAR = 1
integer, parameter, public :: REAL_FINITE = 2
@
<<Process mci: process mci entry: TBP>>=
procedure :: create_component_list => &
process_mci_entry_create_component_list
<<Process mci: sub interfaces>>=
module subroutine process_mci_entry_create_component_list (mci_entry, &
i_component, component_config)
class (process_mci_entry_t), intent(inout) :: mci_entry
integer, intent(in) :: i_component
type(process_component_def_t), intent(in) :: component_config
end subroutine process_mci_entry_create_component_list
<<Process mci: procedures>>=
module subroutine process_mci_entry_create_component_list (mci_entry, &
i_component, component_config)
class (process_mci_entry_t), intent(inout) :: mci_entry
integer, intent(in) :: i_component
type(process_component_def_t), intent(in) :: component_config
integer, dimension(:), allocatable :: i_list
integer :: n
integer, save :: i_rfin_offset = 0
if (debug_on) call msg_debug &
(D_PROCESS_INTEGRATION, "process_mci_entry_create_component_list")
if (mci_entry%combined_integration) then
if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
"mci_entry%real_partition_type", mci_entry%real_partition_type)
n = get_n_components (mci_entry%real_partition_type)
allocate (i_list (n))
select case (mci_entry%real_partition_type)
case (REAL_FULL)
i_list = component_config%get_association_list ()
allocate (mci_entry%i_component (size (i_list)))
mci_entry%i_component = i_list
case (REAL_SINGULAR)
i_list = component_config%get_association_list (ASSOCIATED_REAL_FIN)
allocate (mci_entry%i_component (size(i_list)))
mci_entry%i_component = i_list
case (REAL_FINITE)
allocate (mci_entry%i_component (1))
mci_entry%i_component(1) = &
component_config%get_associated_real_fin () + i_rfin_offset
i_rfin_offset = i_rfin_offset + 1
end select
else
allocate (mci_entry%i_component (1))
mci_entry%i_component(1) = i_component
end if
contains
function get_n_components (real_partition_type) result (n_components)
integer :: n_components
integer, intent(in) :: real_partition_type
select case (real_partition_type)
case (REAL_FULL)
n_components = size (component_config%get_association_list ())
case (REAL_SINGULAR)
n_components = size (component_config%get_association_list &
(ASSOCIATED_REAL_FIN))
end select
if (debug_on) call msg_debug &
(D_PROCESS_INTEGRATION, "n_components", n_components)
end function get_n_components
end subroutine process_mci_entry_create_component_list
@ %def process_mci_entry_create_component_list
@ Set some additional parameters.
<<Process mci: process mci entry: TBP>>=
procedure :: set_parameters => process_mci_entry_set_parameters
<<Process mci: sub interfaces>>=
module subroutine process_mci_entry_set_parameters (mci_entry, var_list)
class(process_mci_entry_t), intent(inout) :: mci_entry
type(var_list_t), intent(in) :: var_list
end subroutine process_mci_entry_set_parameters
<<Process mci: procedures>>=
module subroutine process_mci_entry_set_parameters (mci_entry, var_list)
class(process_mci_entry_t), intent(inout) :: mci_entry
type(var_list_t), intent(in) :: var_list
integer :: integration_results_verbosity
real(default) :: error_threshold
integration_results_verbosity = &
var_list%get_ival (var_str ("integration_results_verbosity"))
error_threshold = &
var_list%get_rval (var_str ("error_threshold"))
mci_entry%activate_timer = &
var_list%get_lval (var_str ("?integration_timer"))
call mci_entry%results%set_verbosity (integration_results_verbosity)
call mci_entry%results%set_error_threshold (error_threshold)
end subroutine process_mci_entry_set_parameters
@ %def process_mci_entry_set_parameters
@ Compute an MD5 sum that summarizes all information that could
influence integration results, for the associated process components.
We take the process-configuration MD5 sum which represents parameters,
cuts, etc., the MD5 sums for the process component definitions and
their phase space objects (which should be configured), and the beam
configuration MD5 sum. (The QCD setup is included in the process
configuration data MD5 sum.)
Done only once, when the MD5 sum is still empty.
<<Process mci: process mci entry: TBP>>=
procedure :: compute_md5sum => process_mci_entry_compute_md5sum
<<Process mci: sub interfaces>>=
module subroutine process_mci_entry_compute_md5sum (mci_entry, &
config, component, beam_config)
class(process_mci_entry_t), intent(inout) :: mci_entry
type(process_config_data_t), intent(in) :: config
type(process_component_t), dimension(:), intent(in) :: component
type(process_beam_config_t), intent(in) :: beam_config
end subroutine process_mci_entry_compute_md5sum
<<Process mci: procedures>>=
module subroutine process_mci_entry_compute_md5sum (mci_entry, &
config, component, beam_config)
class(process_mci_entry_t), intent(inout) :: mci_entry
type(process_config_data_t), intent(in) :: config
type(process_component_t), dimension(:), intent(in) :: component
type(process_beam_config_t), intent(in) :: beam_config
type(string_t) :: buffer
integer :: i
if (mci_entry%md5sum == "") then
buffer = config%get_md5sum () // beam_config%get_md5sum ()
do i = 1, size (component)
if (component(i)%is_active ()) then
buffer = buffer // component(i)%get_md5sum ()
end if
end do
mci_entry%md5sum = md5sum (char (buffer))
end if
if (allocated (mci_entry%mci)) then
call mci_entry%mci%set_md5sum (mci_entry%md5sum)
end if
end subroutine process_mci_entry_compute_md5sum
@ %def process_mci_entry_compute_md5sum
@ Test the MCI sampler by calling it a given number of time, discarding the
results. The instance should be initialized.
The [[mci_entry]] is [[intent(inout)]] because the integrator contains
the random-number state.
<<Process mci: process mci entry: TBP>>=
procedure :: sampler_test => process_mci_entry_sampler_test
<<Process mci: sub interfaces>>=
module subroutine process_mci_entry_sampler_test &
(mci_entry, mci_sampler, n_calls)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_sampler_t), intent(inout), target :: mci_sampler
integer, intent(in) :: n_calls
end subroutine process_mci_entry_sampler_test
<<Process mci: procedures>>=
module subroutine process_mci_entry_sampler_test &
(mci_entry, mci_sampler, n_calls)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_sampler_t), intent(inout), target :: mci_sampler
integer, intent(in) :: n_calls
call mci_entry%mci%sampler_test (mci_sampler, n_calls)
end subroutine process_mci_entry_sampler_test
@ %def process_mci_entry_sampler_test
@ Integrate.
The [[integrate]] method counts as an integration pass; the pass count is
increased by one. We transfer the pass parameters (number of iterations and
number of calls) to the actual integration routine.
The [[mci_entry]] is [[intent(inout)]] because the integrator contains
the random-number state.
Note: The results are written to screen and to logfile. This behavior
is hardcoded.
<<Process mci: process mci entry: TBP>>=
procedure :: integrate => process_mci_entry_integrate
procedure :: final_integration => process_mci_entry_final_integration
<<Process mci: sub interfaces>>=
module subroutine process_mci_entry_integrate (mci_entry, mci_instance, &
mci_sampler, n_it, n_calls, &
adapt_grids, adapt_weights, final, pacify, &
nlo_type)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_instance_t), intent(inout) :: mci_instance
class(mci_sampler_t), intent(inout) :: mci_sampler
integer, intent(in) :: n_it
integer, intent(in) :: n_calls
logical, intent(in), optional :: adapt_grids
logical, intent(in), optional :: adapt_weights
logical, intent(in), optional :: final, pacify
integer, intent(in), optional :: nlo_type
end subroutine process_mci_entry_integrate
module subroutine process_mci_entry_final_integration (mci_entry)
class(process_mci_entry_t), intent(inout) :: mci_entry
end subroutine process_mci_entry_final_integration
<<Process mci: procedures>>=
module subroutine process_mci_entry_integrate (mci_entry, mci_instance, &
mci_sampler, n_it, n_calls, &
adapt_grids, adapt_weights, final, pacify, &
nlo_type)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_instance_t), intent(inout) :: mci_instance
class(mci_sampler_t), intent(inout) :: mci_sampler
integer, intent(in) :: n_it
integer, intent(in) :: n_calls
logical, intent(in), optional :: adapt_grids
logical, intent(in), optional :: adapt_weights
logical, intent(in), optional :: final, pacify
integer, intent(in), optional :: nlo_type
integer :: u_log
u_log = logfile_unit ()
mci_entry%pass = mci_entry%pass + 1
mci_entry%n_it = n_it
mci_entry%n_calls = n_calls
if (mci_entry%pass == 1) &
call mci_entry%mci%startup_message (n_calls = n_calls)
call mci_entry%mci%set_timer (active = mci_entry%activate_timer)
call mci_entry%results%display_init (screen = .true., unit = u_log)
call mci_entry%results%new_pass ()
if (present (nlo_type)) then
select case (nlo_type)
case (NLO_VIRTUAL, NLO_REAL, NLO_MISMATCH, NLO_DGLAP)
mci_instance%negative_weights = .true.
end select
end if
call mci_entry%mci%add_pass (adapt_grids, adapt_weights, final)
call mci_entry%mci%start_timer ()
call mci_entry%mci%integrate (mci_instance, mci_sampler, n_it, &
n_calls, mci_entry%results, pacify = pacify)
call mci_entry%mci%stop_timer ()
if (signal_is_pending ()) return
end subroutine process_mci_entry_integrate
module subroutine process_mci_entry_final_integration (mci_entry)
class(process_mci_entry_t), intent(inout) :: mci_entry
call mci_entry%results%display_final ()
call mci_entry%time_message ()
end subroutine process_mci_entry_final_integration
@ %def process_mci_entry_integrate
@ %def process_mci_entry_final_integration
@ If appropriate, issue an informative message about the expected time
for an event sample.
<<Process mci: process mci entry: TBP>>=
procedure :: get_time => process_mci_entry_get_time
procedure :: time_message => process_mci_entry_time_message
<<Process mci: sub interfaces>>=
module subroutine process_mci_entry_get_time (mci_entry, time, sample)
class(process_mci_entry_t), intent(in) :: mci_entry
type(time_t), intent(out) :: time
integer, intent(in) :: sample
end subroutine process_mci_entry_get_time
module subroutine process_mci_entry_time_message (mci_entry)
class(process_mci_entry_t), intent(in) :: mci_entry
end subroutine process_mci_entry_time_message
<<Process mci: procedures>>=
module subroutine process_mci_entry_get_time (mci_entry, time, sample)
class(process_mci_entry_t), intent(in) :: mci_entry
type(time_t), intent(out) :: time
integer, intent(in) :: sample
real(default) :: time_last_pass, efficiency, calls
time_last_pass = mci_entry%mci%get_time ()
calls = mci_entry%results%get_n_calls ()
efficiency = mci_entry%mci%get_efficiency ()
if (time_last_pass > 0 .and. calls > 0 .and. efficiency > 0) then
time = nint (time_last_pass / calls / efficiency * sample)
end if
end subroutine process_mci_entry_get_time
module subroutine process_mci_entry_time_message (mci_entry)
class(process_mci_entry_t), intent(in) :: mci_entry
type(time_t) :: time
integer :: sample
sample = 10000
call mci_entry%get_time (time, sample)
if (time%is_known ()) then
call msg_message ("Time estimate for generating 10000 events: " &
// char (time%to_string_dhms ()))
end if
end subroutine process_mci_entry_time_message
@ %def process_mci_entry_time_message
@ Prepare event generation. (For the test integrator, this does nothing. It
is relevant for the VAMP integrator.)
<<Process mci: process mci entry: TBP>>=
procedure :: prepare_simulation => process_mci_entry_prepare_simulation
<<Process mci: sub interfaces>>=
module subroutine process_mci_entry_prepare_simulation (mci_entry)
class(process_mci_entry_t), intent(inout) :: mci_entry
end subroutine process_mci_entry_prepare_simulation
<<Process mci: procedures>>=
module subroutine process_mci_entry_prepare_simulation (mci_entry)
class(process_mci_entry_t), intent(inout) :: mci_entry
call mci_entry%mci%prepare_simulation ()
end subroutine process_mci_entry_prepare_simulation
@ %def process_mci_entry_prepare_simulation
@ Generate an event. The instance should be initialized,
otherwise event generation is directed by the [[mci]] integrator
subobject. The integrator instance is contained in a [[mci_work]]
subobject of the process instance, which simultaneously serves as the
sampler object. (We avoid the anti-aliasing rules if we assume that
the sampling itself does not involve the integrator instance contained in the
process instance.)
Regarding weighted events, we only take events which are valid, which
means that they have valid kinematics and have passed cuts.
Therefore, we have a rejection loop. For unweighted events, the
unweighting routine should already take care of this.
The [[keep_failed]] flag determines whether events which failed cuts
are nevertheless produced, to be recorded with zero weight.
Alternatively, failed events are dropped, and this fact is recorded by
the counter [[n_dropped]].
<<Process mci: process mci entry: TBP>>=
procedure :: generate_weighted_event => &
process_mci_entry_generate_weighted_event
procedure :: generate_unweighted_event => &
process_mci_entry_generate_unweighted_event
<<Process mci: sub interfaces>>=
module subroutine process_mci_entry_generate_weighted_event (mci_entry, &
mci_instance, mci_sampler, keep_failed)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_instance_t), intent(inout) :: mci_instance
class(mci_sampler_t), intent(inout) :: mci_sampler
logical, intent(in) :: keep_failed
end subroutine process_mci_entry_generate_weighted_event
module subroutine process_mci_entry_generate_unweighted_event &
(mci_entry, mci_instance, mci_sampler)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_instance_t), intent(inout) :: mci_instance
class(mci_sampler_t), intent(inout) :: mci_sampler
end subroutine process_mci_entry_generate_unweighted_event
<<Process mci: procedures>>=
module subroutine process_mci_entry_generate_weighted_event (mci_entry, &
mci_instance, mci_sampler, keep_failed)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_instance_t), intent(inout) :: mci_instance
class(mci_sampler_t), intent(inout) :: mci_sampler
logical, intent(in) :: keep_failed
logical :: generate_new
generate_new = .true.
call mci_instance%reset_n_event_dropped ()
REJECTION: do while (generate_new)
call mci_entry%mci%generate_weighted_event (mci_instance, mci_sampler)
if (signal_is_pending ()) return
if (.not. mci_sampler%is_valid()) then
if (keep_failed) then
generate_new = .false.
else
call mci_instance%record_event_dropped ()
generate_new = .true.
end if
else
generate_new = .false.
end if
end do REJECTION
end subroutine process_mci_entry_generate_weighted_event
module subroutine process_mci_entry_generate_unweighted_event &
(mci_entry, mci_instance, mci_sampler)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_instance_t), intent(inout) :: mci_instance
class(mci_sampler_t), intent(inout) :: mci_sampler
call mci_entry%mci%generate_unweighted_event (mci_instance, mci_sampler)
end subroutine process_mci_entry_generate_unweighted_event
@ %def process_mci_entry_generate_weighted_event
@ %def process_mci_entry_generate_unweighted_event
@ Extract results.
<<Process mci: process mci entry: TBP>>=
procedure :: has_integral => process_mci_entry_has_integral
procedure :: get_integral => process_mci_entry_get_integral
procedure :: get_error => process_mci_entry_get_error
procedure :: get_accuracy => process_mci_entry_get_accuracy
procedure :: get_chi2 => process_mci_entry_get_chi2
procedure :: get_efficiency => process_mci_entry_get_efficiency
<<Process mci: sub interfaces>>=
module function process_mci_entry_has_integral (mci_entry) result (flag)
class(process_mci_entry_t), intent(in) :: mci_entry
logical :: flag
end function process_mci_entry_has_integral
module function process_mci_entry_get_integral (mci_entry) result (integral)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: integral
end function process_mci_entry_get_integral
module function process_mci_entry_get_error (mci_entry) result (error)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: error
end function process_mci_entry_get_error
module function process_mci_entry_get_accuracy (mci_entry) result (accuracy)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: accuracy
end function process_mci_entry_get_accuracy
module function process_mci_entry_get_chi2 (mci_entry) result (chi2)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: chi2
end function process_mci_entry_get_chi2
module function process_mci_entry_get_efficiency &
(mci_entry) result (efficiency)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: efficiency
end function process_mci_entry_get_efficiency
<<Process mci: procedures>>=
module function process_mci_entry_has_integral (mci_entry) result (flag)
class(process_mci_entry_t), intent(in) :: mci_entry
logical :: flag
flag = mci_entry%results%exist ()
end function process_mci_entry_has_integral
module function process_mci_entry_get_integral (mci_entry) result (integral)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: integral
integral = mci_entry%results%get_integral ()
end function process_mci_entry_get_integral
module function process_mci_entry_get_error (mci_entry) result (error)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: error
error = mci_entry%results%get_error ()
end function process_mci_entry_get_error
module function process_mci_entry_get_accuracy (mci_entry) result (accuracy)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: accuracy
accuracy = mci_entry%results%get_accuracy ()
end function process_mci_entry_get_accuracy
module function process_mci_entry_get_chi2 (mci_entry) result (chi2)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: chi2
chi2 = mci_entry%results%get_chi2 ()
end function process_mci_entry_get_chi2
module function process_mci_entry_get_efficiency &
(mci_entry) result (efficiency)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: efficiency
efficiency = mci_entry%results%get_efficiency ()
end function process_mci_entry_get_efficiency
@ %def process_mci_entry_get_integral process_mci_entry_get_error
@ %def process_mci_entry_get_accuracy process_mci_entry_get_chi2
@ %def process_mci_entry_get_efficiency
@ Return the MCI checksum. This may be the one used for
configuration, but may also incorporate results, if they change the
state of the integrator (adaptation).
<<Process mci: process mci entry: TBP>>=
procedure :: get_md5sum => process_mci_entry_get_md5sum
<<Process mci: sub interfaces>>=
pure module function process_mci_entry_get_md5sum (entry) result (md5sum)
class(process_mci_entry_t), intent(in) :: entry
character(32) :: md5sum
end function process_mci_entry_get_md5sum
<<Process mci: procedures>>=
pure module function process_mci_entry_get_md5sum (entry) result (md5sum)
class(process_mci_entry_t), intent(in) :: entry
character(32) :: md5sum
md5sum = entry%mci%get_md5sum ()
end function process_mci_entry_get_md5sum
@ %def process_mci_entry_get_md5sum
@
\subsection{MC parameter set and MCI instance}
For each process component that is associated with a multi-channel integration
(MCI) object, the [[mci_work_t]] object contains the currently active
parameter set. It also holds the implementation of the [[mci_instance_t]]
that the integrator needs for doing its work.
<<Process mci: public>>=
public :: mci_work_t
<<Process mci: types>>=
type :: mci_work_t
type(process_mci_entry_t), pointer :: config => null ()
real(default), dimension(:), allocatable :: x
class(mci_instance_t), pointer :: mci => null ()
type(process_counter_t) :: counter
logical :: keep_failed_events = .false.
integer :: n_event_dropped = 0
contains
<<Process mci: mci work: TBP>>
end type mci_work_t
@ %def mci_work_t
@ First write configuration data, then the current values.
<<Process mci: mci work: TBP>>=
procedure :: write => mci_work_write
<<Process mci: sub interfaces>>=
module subroutine mci_work_write (mci_work, unit, testflag)
class(mci_work_t), intent(in) :: mci_work
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
end subroutine mci_work_write
<<Process mci: procedures>>=
module subroutine mci_work_write (mci_work, unit, testflag)
class(mci_work_t), intent(in) :: mci_work
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
integer :: u, i
u = given_output_unit (unit)
write (u, "(1x,A,I0,A)") "Active MCI instance #", &
mci_work%config%i_mci, " ="
write (u, "(2x)", advance="no")
do i = 1, mci_work%config%n_par
write (u, "(1x,F7.5)", advance="no") mci_work%x(i)
if (i == mci_work%config%n_par_sf) &
write (u, "(1x,'|')", advance="no")
end do
write (u, *)
if (associated (mci_work%mci)) then
call mci_work%mci%write (u, pacify = testflag)
call mci_work%counter%write (u)
end if
end subroutine mci_work_write
@ %def mci_work_write
@ The [[mci]] component may require finalization.
<<Process mci: mci work: TBP>>=
procedure :: final => mci_work_final
<<Process mci: sub interfaces>>=
module subroutine mci_work_final (mci_work)
class(mci_work_t), intent(inout) :: mci_work
end subroutine mci_work_final
<<Process mci: procedures>>=
module subroutine mci_work_final (mci_work)
class(mci_work_t), intent(inout) :: mci_work
if (associated (mci_work%mci)) then
call mci_work%mci%final ()
deallocate (mci_work%mci)
end if
end subroutine mci_work_final
@ %def mci_work_final
@ Initialize with the maximum length that we will need. Contents are
not initialized.
The integrator inside the [[mci_entry]] object is responsible for
allocating and initializing its own instance, which is referred to by
a pointer in the [[mci_work]] object.
<<Process mci: mci work: TBP>>=
procedure :: init => mci_work_init
<<Process mci: sub interfaces>>=
module subroutine mci_work_init (mci_work, mci_entry)
class(mci_work_t), intent(out) :: mci_work
type(process_mci_entry_t), intent(in), target :: mci_entry
end subroutine mci_work_init
<<Process mci: procedures>>=
module subroutine mci_work_init (mci_work, mci_entry)
class(mci_work_t), intent(out) :: mci_work
type(process_mci_entry_t), intent(in), target :: mci_entry
mci_work%config => mci_entry
allocate (mci_work%x (mci_entry%n_par))
if (allocated (mci_entry%mci)) then
call mci_entry%mci%allocate_instance (mci_work%mci)
call mci_work%mci%init (mci_entry%mci)
end if
end subroutine mci_work_init
@ %def mci_work_init
@ Set parameters explicitly, either all at once, or separately for the
structure-function and process parts.
<<Process mci: mci work: TBP>>=
procedure :: set => mci_work_set
procedure :: set_x_strfun => mci_work_set_x_strfun
procedure :: set_x_process => mci_work_set_x_process
<<Process mci: sub interfaces>>=
module subroutine mci_work_set (mci_work, x)
class(mci_work_t), intent(inout) :: mci_work
real(default), dimension(:), intent(in) :: x
end subroutine mci_work_set
module subroutine mci_work_set_x_strfun (mci_work, x)
class(mci_work_t), intent(inout) :: mci_work
real(default), dimension(:), intent(in) :: x
end subroutine mci_work_set_x_strfun
module subroutine mci_work_set_x_process (mci_work, x)
class(mci_work_t), intent(inout) :: mci_work
real(default), dimension(:), intent(in) :: x
end subroutine mci_work_set_x_process
<<Process mci: procedures>>=
module subroutine mci_work_set (mci_work, x)
class(mci_work_t), intent(inout) :: mci_work
real(default), dimension(:), intent(in) :: x
mci_work%x = x
end subroutine mci_work_set
module subroutine mci_work_set_x_strfun (mci_work, x)
class(mci_work_t), intent(inout) :: mci_work
real(default), dimension(:), intent(in) :: x
mci_work%x(1 : mci_work%config%n_par_sf) = x
end subroutine mci_work_set_x_strfun
module subroutine mci_work_set_x_process (mci_work, x)
class(mci_work_t), intent(inout) :: mci_work
real(default), dimension(:), intent(in) :: x
mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par) = x
end subroutine mci_work_set_x_process
@ %def mci_work_set
@ %def mci_work_set_x_strfun
@ %def mci_work_set_x_process
@ Return the array of active components, i.e., those that correspond
to the currently selected MC parameter set.
<<Process mci: mci work: TBP>>=
procedure :: get_active_components => mci_work_get_active_components
<<Process mci: sub interfaces>>=
module function mci_work_get_active_components &
(mci_work) result (i_component)
class(mci_work_t), intent(in) :: mci_work
integer, dimension(:), allocatable :: i_component
end function mci_work_get_active_components
<<Process mci: procedures>>=
module function mci_work_get_active_components (mci_work) result (i_component)
class(mci_work_t), intent(in) :: mci_work
integer, dimension(:), allocatable :: i_component
allocate (i_component (size (mci_work%config%i_component)))
i_component = mci_work%config%i_component
end function mci_work_get_active_components
@ %def mci_work_get_active_components
@ Return the active parameters as a simple array with correct length.
Do this separately for the structure-function parameters and the
process parameters.
<<Process mci: mci work: TBP>>=
procedure :: get_x_strfun => mci_work_get_x_strfun
procedure :: get_x_process => mci_work_get_x_process
<<Process mci: sub interfaces>>=
pure module function mci_work_get_x_strfun (mci_work) result (x)
class(mci_work_t), intent(in) :: mci_work
real(default), dimension(mci_work%config%n_par_sf) :: x
end function mci_work_get_x_strfun
pure module function mci_work_get_x_process (mci_work) result (x)
class(mci_work_t), intent(in) :: mci_work
real(default), dimension(mci_work%config%n_par_phs) :: x
end function mci_work_get_x_process
<<Process mci: procedures>>=
pure module function mci_work_get_x_strfun (mci_work) result (x)
class(mci_work_t), intent(in) :: mci_work
real(default), dimension(mci_work%config%n_par_sf) :: x
x = mci_work%x(1 : mci_work%config%n_par_sf)
end function mci_work_get_x_strfun
pure module function mci_work_get_x_process (mci_work) result (x)
class(mci_work_t), intent(in) :: mci_work
real(default), dimension(mci_work%config%n_par_phs) :: x
x = mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par)
end function mci_work_get_x_process
@ %def mci_work_get_x_strfun
@ %def mci_work_get_x_process
@ Initialize and finalize event generation for the specified MCI
entry. This also resets the counter.
<<Process mci: mci work: TBP>>=
procedure :: init_simulation => mci_work_init_simulation
procedure :: final_simulation => mci_work_final_simulation
<<Process mci: sub interfaces>>=
module subroutine mci_work_final_simulation (mci_work)
class(mci_work_t), intent(inout) :: mci_work
end subroutine mci_work_final_simulation
module subroutine mci_work_init_simulation &
(mci_work, safety_factor, keep_failed_events)
class(mci_work_t), intent(inout) :: mci_work
real(default), intent(in), optional :: safety_factor
logical, intent(in), optional :: keep_failed_events
end subroutine mci_work_init_simulation
<<Process mci: procedures>>=
module subroutine mci_work_init_simulation &
(mci_work, safety_factor, keep_failed_events)
class(mci_work_t), intent(inout) :: mci_work
real(default), intent(in), optional :: safety_factor
logical, intent(in), optional :: keep_failed_events
call mci_work%mci%init_simulation (safety_factor)
call mci_work%counter%reset ()
if (present (keep_failed_events)) &
mci_work%keep_failed_events = keep_failed_events
end subroutine mci_work_init_simulation
module subroutine mci_work_final_simulation (mci_work)
class(mci_work_t), intent(inout) :: mci_work
call mci_work%mci%final_simulation ()
end subroutine mci_work_final_simulation
@ %def mci_work_init_simulation
@ %def mci_work_final_simulation
@ Counter.
<<Process mci: mci work: TBP>>=
procedure :: reset_counter => mci_work_reset_counter
procedure :: record_call => mci_work_record_call
procedure :: get_counter => mci_work_get_counter
<<Process mci: sub interfaces>>=
module subroutine mci_work_reset_counter (mci_work)
class(mci_work_t), intent(inout) :: mci_work
end subroutine mci_work_reset_counter
module subroutine mci_work_record_call (mci_work, status)
class(mci_work_t), intent(inout) :: mci_work
integer, intent(in) :: status
end subroutine mci_work_record_call
pure module function mci_work_get_counter (mci_work) result (counter)
class(mci_work_t), intent(in) :: mci_work
type(process_counter_t) :: counter
end function mci_work_get_counter
<<Process mci: procedures>>=
module subroutine mci_work_reset_counter (mci_work)
class(mci_work_t), intent(inout) :: mci_work
call mci_work%counter%reset ()
end subroutine mci_work_reset_counter
module subroutine mci_work_record_call (mci_work, status)
class(mci_work_t), intent(inout) :: mci_work
integer, intent(in) :: status
call mci_work%counter%record (status)
end subroutine mci_work_record_call
pure module function mci_work_get_counter (mci_work) result (counter)
class(mci_work_t), intent(in) :: mci_work
type(process_counter_t) :: counter
counter = mci_work%counter
end function mci_work_get_counter
@ %def mci_work_reset_counter
@ %def mci_work_record_call
@ %def mci_work_get_counter
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Process component manager}
<<[[pcm.f90]]>>=
<<File header>>
module pcm
<<Use kinds>>
<<Use strings>>
use lorentz
use model_data, only: model_data_t
use models, only: model_t
use quantum_numbers, only: quantum_numbers_t, quantum_numbers_mask_t
use variables, only: var_list_t
use nlo_data, only: nlo_settings_t
use nlo_data, only: fks_template_t
use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES
use mci_base, only: mci_t
use phs_base, only: phs_config_t
use mappings, only: mapping_defaults_t
use phs_forests, only: phs_parameters_t
use phs_fks, only: isr_kinematics_t, real_kinematics_t
use phs_fks, only: phs_identifier_t
use fks_regions, only: region_data_t
use phs_fks, only: phs_fks_generator_t
use phs_fks, only: dalitz_plot_t
use phs_fks, only: phs_fks_config_t, get_filtered_resonance_histories
use dispatch_phase_space, only: dispatch_phs
use real_subtraction, only: real_subtraction_t, soft_mismatch_t
use real_subtraction, only: INTEGRATION, FIXED_ORDER_EVENTS
use real_subtraction, only: real_partition_t, powheg_damping_simple_t
use real_subtraction, only: real_partition_fixed_order_t
use virtual, only: virtual_t
use dglap_remnant, only: dglap_remnant_t
use blha_config, only: blha_master_t
use pcm_base
use process_config
use process_mci, only: process_mci_entry_t
use process_mci, only: REAL_SINGULAR, REAL_FINITE
<<Standard module head>>
<<PCM: public>>
<<PCM: types>>
interface
<<PCM: sub interfaces>>
end interface
contains
<<PCM: main procedures>>
end module pcm
@ %def pcm
@
<<[[pcm_sub.f90]]>>=
<<File header>>
submodule (pcm) pcm_s
<<Use debug>>
use constants, only: zero, two
use diagnostics
use phs_points, only: assignment(=)
use io_units, only: free_unit
use os_interface
use process_constants, only: process_constants_t
use physics_defs
use flavors, only: flavor_t
use interactions, only: interaction_t
use dispatch_fks, only: dispatch_fks_setup
use process_libraries, only: process_component_def_t
use resonances, only: resonance_history_t, resonance_history_set_t
use prc_threshold, only: threshold_def_t
use blha_olp_interfaces, only: prc_blha_t
implicit none
contains
<<PCM: procedures>>
end submodule pcm_s
@ %def pcm_s
@
\subsection{Default process component manager}
This is the configuration object which has the duty of allocating the
corresponding instance. The default version is trivial.
<<PCM: public>>=
public :: pcm_default_t
<<PCM: types>>=
type, extends (pcm_t) :: pcm_default_t
contains
<<PCM: pcm default: TBP>>
end type pcm_default_t
@ %def pcm_default_t
Gfortran 7/8/9 bug, has to remain in the main module:
<<PCM: pcm default: TBP>>=
procedure :: allocate_workspace => pcm_default_allocate_workspace
<<PCM: main procedures>>=
subroutine pcm_default_allocate_workspace (pcm, work)
class(pcm_default_t), intent(in) :: pcm
class(pcm_workspace_t), intent(inout), allocatable :: work
allocate (pcm_default_workspace_t :: work)
end subroutine pcm_default_allocate_workspace
@ %def pcm_default_allocate_workspace
@
Finalizer: apply to core manager.
<<PCM: pcm default: TBP>>=
procedure :: final => pcm_default_final
<<PCM: sub interfaces>>=
module subroutine pcm_default_final (pcm)
class(pcm_default_t), intent(inout) :: pcm
end subroutine pcm_default_final
<<PCM: procedures>>=
module subroutine pcm_default_final (pcm)
class(pcm_default_t), intent(inout) :: pcm
end subroutine pcm_default_final
@ %def pcm_default_final
@
<<PCM: pcm default: TBP>>=
procedure :: is_nlo => pcm_default_is_nlo
<<PCM: sub interfaces>>=
module function pcm_default_is_nlo (pcm) result (is_nlo)
logical :: is_nlo
class(pcm_default_t), intent(in) :: pcm
end function pcm_default_is_nlo
<<PCM: procedures>>=
module function pcm_default_is_nlo (pcm) result (is_nlo)
logical :: is_nlo
class(pcm_default_t), intent(in) :: pcm
is_nlo = .false.
end function pcm_default_is_nlo
@ %def pcm_default_is_nlo
@
Initialize configuration data, using environment variables.
<<PCM: pcm default: TBP>>=
procedure :: init => pcm_default_init
<<PCM: sub interfaces>>=
module subroutine pcm_default_init (pcm, env, meta)
class(pcm_default_t), intent(out) :: pcm
type(process_environment_t), intent(in) :: env
type(process_metadata_t), intent(in) :: meta
end subroutine pcm_default_init
<<PCM: procedures>>=
module subroutine pcm_default_init (pcm, env, meta)
class(pcm_default_t), intent(out) :: pcm
type(process_environment_t), intent(in) :: env
type(process_metadata_t), intent(in) :: meta
pcm%has_pdfs = env%has_pdfs ()
call pcm%set_blha_defaults &
(env%has_polarized_beams (), env%get_var_list_ptr ())
pcm%os_data = env%get_os_data ()
end subroutine pcm_default_init
@ %def pcm_default_init
@
<<PCM: types>>=
type, extends (pcm_workspace_t) :: pcm_default_workspace_t
contains
<<PCM: pcm instance default: TBP>>
end type pcm_default_workspace_t
@ %def pcm_default_workspace_t
@
<<PCM: pcm instance default: TBP>>=
procedure :: final => pcm_default_workspace_final
<<PCM: sub interfaces>>=
module subroutine pcm_default_workspace_final (pcm_work)
class(pcm_default_workspace_t), intent(inout) :: pcm_work
end subroutine pcm_default_workspace_final
<<PCM: procedures>>=
module subroutine pcm_default_workspace_final (pcm_work)
class(pcm_default_workspace_t), intent(inout) :: pcm_work
end subroutine pcm_default_workspace_final
@ %def pcm_default_workspace_final
@
<<PCM: pcm instance default: TBP>>=
procedure :: is_nlo => pcm_default_workspace_is_nlo
<<PCM: sub interfaces>>=
module function pcm_default_workspace_is_nlo (pcm_work) result (is_nlo)
logical :: is_nlo
class(pcm_default_workspace_t), intent(inout) :: pcm_work
end function pcm_default_workspace_is_nlo
<<PCM: procedures>>=
module function pcm_default_workspace_is_nlo (pcm_work) result (is_nlo)
logical :: is_nlo
class(pcm_default_workspace_t), intent(inout) :: pcm_work
is_nlo = .false.
end function pcm_default_workspace_is_nlo
@ %def pcm_default_workspace_is_nlo
@
\subsection{Implementations for the default manager}
Categorize components. Nothing to do here, all components are of Born type.
<<PCM: pcm default: TBP>>=
procedure :: categorize_components => pcm_default_categorize_components
<<PCM: sub interfaces>>=
module subroutine pcm_default_categorize_components (pcm, config)
class(pcm_default_t), intent(inout) :: pcm
type(process_config_data_t), intent(in) :: config
end subroutine pcm_default_categorize_components
<<PCM: procedures>>=
module subroutine pcm_default_categorize_components (pcm, config)
class(pcm_default_t), intent(inout) :: pcm
type(process_config_data_t), intent(in) :: config
end subroutine pcm_default_categorize_components
@ %def pcm_default_categorize_components
@
\subsubsection{Phase-space configuration}
Default setup for tree processes: a single phase-space configuration that is
valid for all components.
<<PCM: pcm default: TBP>>=
procedure :: init_phs_config => pcm_default_init_phs_config
<<PCM: sub interfaces>>=
module subroutine pcm_default_init_phs_config &
(pcm, phs_entry, meta, env, phs_par, mapping_defs)
class(pcm_default_t), intent(inout) :: pcm
type(process_phs_config_t), &
dimension(:), allocatable, intent(out) :: phs_entry
type(process_metadata_t), intent(in) :: meta
type(process_environment_t), intent(in) :: env
type(mapping_defaults_t), intent(in) :: mapping_defs
type(phs_parameters_t), intent(in) :: phs_par
end subroutine pcm_default_init_phs_config
<<PCM: procedures>>=
module subroutine pcm_default_init_phs_config &
(pcm, phs_entry, meta, env, phs_par, mapping_defs)
class(pcm_default_t), intent(inout) :: pcm
type(process_phs_config_t), &
dimension(:), allocatable, intent(out) :: phs_entry
type(process_metadata_t), intent(in) :: meta
type(process_environment_t), intent(in) :: env
type(mapping_defaults_t), intent(in) :: mapping_defs
type(phs_parameters_t), intent(in) :: phs_par
allocate (phs_entry (1))
allocate (pcm%i_phs_config (pcm%n_components), source=1)
call dispatch_phs (phs_entry(1)%phs_config, &
env%get_var_list_ptr (), &
env%get_os_data (), &
meta%id, &
mapping_defs, phs_par)
end subroutine pcm_default_init_phs_config
@ %def pcm_default_init_phs_config
@
\subsubsection{Core management}
The default component manager assigns one core per component. We allocate and
configure the core objects, using the process-component configuration data.
<<PCM: pcm default: TBP>>=
procedure :: allocate_cores => pcm_default_allocate_cores
<<PCM: sub interfaces>>=
module subroutine pcm_default_allocate_cores (pcm, config, core_entry)
class(pcm_default_t), intent(inout) :: pcm
type(process_config_data_t), intent(in) :: config
type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
end subroutine pcm_default_allocate_cores
<<PCM: procedures>>=
module subroutine pcm_default_allocate_cores (pcm, config, core_entry)
class(pcm_default_t), intent(inout) :: pcm
type(process_config_data_t), intent(in) :: config
type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
type(process_component_def_t), pointer :: component_def
integer :: i
allocate (pcm%i_core (pcm%n_components), source = 0)
pcm%n_cores = pcm%n_components
allocate (core_entry (pcm%n_cores))
do i = 1, pcm%n_cores
pcm%i_core(i) = i
core_entry(i)%i_component = i
component_def => config%process_def%get_component_def_ptr (i)
core_entry(i)%core_def => component_def%get_core_def_ptr ()
core_entry(i)%active = component_def%can_be_integrated ()
end do
end subroutine pcm_default_allocate_cores
@ %def pcm_default_allocate_cores
@ Extra code is required for certain core types (threshold) or if BLHA uses an
external OLP (Born only, this case) for getting its matrix elements.
<<PCM: pcm default: TBP>>=
procedure :: prepare_any_external_code => &
pcm_default_prepare_any_external_code
<<PCM: sub interfaces>>=
module subroutine pcm_default_prepare_any_external_code &
(pcm, core_entry, i_core, libname, model, var_list)
class(pcm_default_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
integer, intent(in) :: i_core
type(string_t), intent(in) :: libname
type(model_data_t), intent(in), target :: model
type(var_list_t), intent(in) :: var_list
end subroutine pcm_default_prepare_any_external_code
<<PCM: procedures>>=
module subroutine pcm_default_prepare_any_external_code &
(pcm, core_entry, i_core, libname, model, var_list)
class(pcm_default_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
integer, intent(in) :: i_core
type(string_t), intent(in) :: libname
type(model_data_t), intent(in), target :: model
type(var_list_t), intent(in) :: var_list
if (core_entry%active) then
associate (core => core_entry%core)
if (core%needs_external_code ()) then
call core%prepare_external_code &
(core%data%flv_state, &
var_list, pcm%os_data, libname, model, i_core, .false.)
end if
call core%set_equivalent_flv_hel_indices ()
end associate
end if
end subroutine pcm_default_prepare_any_external_code
@ %def pcm_default_prepare_any_external_code
@ Allocate and configure the BLHA record for a specific core, assuming that
the core type requires it. In the default case, this is a Born
configuration.
<<PCM: pcm default: TBP>>=
procedure :: setup_blha => pcm_default_setup_blha
<<PCM: sub interfaces>>=
module subroutine pcm_default_setup_blha (pcm, core_entry)
class(pcm_default_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
end subroutine pcm_default_setup_blha
<<PCM: procedures>>=
module subroutine pcm_default_setup_blha (pcm, core_entry)
class(pcm_default_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
allocate (core_entry%blha_config, source = pcm%blha_defaults)
call core_entry%blha_config%set_born ()
end subroutine pcm_default_setup_blha
@ %def pcm_default_setup_blha
@ Apply the configuration, using [[pcm]] data.
<<PCM: pcm default: TBP>>=
procedure :: prepare_blha_core => pcm_default_prepare_blha_core
<<PCM: sub interfaces>>=
module subroutine pcm_default_prepare_blha_core (pcm, core_entry, model)
class(pcm_default_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
class(model_data_t), intent(in), target :: model
end subroutine pcm_default_prepare_blha_core
<<PCM: procedures>>=
module subroutine pcm_default_prepare_blha_core (pcm, core_entry, model)
class(pcm_default_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
class(model_data_t), intent(in), target :: model
integer :: n_in
integer :: n_legs
integer :: n_flv
integer :: n_hel
select type (core => core_entry%core)
class is (prc_blha_t)
associate (blha_config => core_entry%blha_config)
n_in = core%data%n_in
n_legs = core%data%get_n_tot ()
n_flv = core%data%n_flv
n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model)
call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel)
call core%init_driver (pcm%os_data)
end associate
end select
end subroutine pcm_default_prepare_blha_core
@ %def pcm_default_prepare_blha_core
@ Read the method settings from the variable list and store them in the BLHA
master. This version: no NLO flag.
<<PCM: pcm default: TBP>>=
procedure :: set_blha_methods => pcm_default_set_blha_methods
<<PCM: sub interfaces>>=
module subroutine pcm_default_set_blha_methods (pcm, blha_master, var_list)
class(pcm_default_t), intent(inout) :: pcm
type(blha_master_t), intent(inout) :: blha_master
type(var_list_t), intent(in) :: var_list
end subroutine pcm_default_set_blha_methods
<<PCM: procedures>>=
module subroutine pcm_default_set_blha_methods (pcm, blha_master, var_list)
class(pcm_default_t), intent(inout) :: pcm
type(blha_master_t), intent(inout) :: blha_master
type(var_list_t), intent(in) :: var_list
call blha_master%set_methods (.false., var_list)
end subroutine pcm_default_set_blha_methods
@ %def pcm_default_set_blha_methods
@ Produce the LO and NLO flavor-state tables (as far as available), as
appropriate for BLHA configuration.
The default version looks at the first process core only, to get the Born
data. (Multiple cores are thus unsupported.) The NLO flavor table is left
unallocated.
<<PCM: pcm default: TBP>>=
procedure :: get_blha_flv_states => pcm_default_get_blha_flv_states
<<PCM: sub interfaces>>=
module subroutine pcm_default_get_blha_flv_states &
(pcm, core_entry, flv_born, flv_real)
class(pcm_default_t), intent(in) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
integer, dimension(:,:), allocatable, intent(out) :: flv_born
integer, dimension(:,:), allocatable, intent(out) :: flv_real
end subroutine pcm_default_get_blha_flv_states
<<PCM: procedures>>=
module subroutine pcm_default_get_blha_flv_states &
(pcm, core_entry, flv_born, flv_real)
class(pcm_default_t), intent(in) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
integer, dimension(:,:), allocatable, intent(out) :: flv_born
integer, dimension(:,:), allocatable, intent(out) :: flv_real
flv_born = core_entry(1)%core%data%flv_state
end subroutine pcm_default_get_blha_flv_states
@ %def pcm_default_get_blha_flv_states
@ Allocate and configure the MCI (multi-channel integrator) records. There is
one record per active process component. Second procedure: call the MCI
dispatcher with default-setup arguments.
<<PCM: pcm default: TBP>>=
procedure :: setup_mci => pcm_default_setup_mci
procedure :: call_dispatch_mci => pcm_default_call_dispatch_mci
<<PCM: sub interfaces>>=
module subroutine pcm_default_setup_mci (pcm, mci_entry)
class(pcm_default_t), intent(inout) :: pcm
type(process_mci_entry_t), &
dimension(:), allocatable, intent(out) :: mci_entry
end subroutine pcm_default_setup_mci
module subroutine pcm_default_call_dispatch_mci (pcm, &
dispatch_mci, var_list, process_id, mci_template)
class(pcm_default_t), intent(inout) :: pcm
procedure(dispatch_mci_proc) :: dispatch_mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
class(mci_t), allocatable, intent(out) :: mci_template
end subroutine pcm_default_call_dispatch_mci
<<PCM: procedures>>=
module subroutine pcm_default_setup_mci (pcm, mci_entry)
class(pcm_default_t), intent(inout) :: pcm
type(process_mci_entry_t), &
dimension(:), allocatable, intent(out) :: mci_entry
class(mci_t), allocatable :: mci_template
integer :: i, i_mci
pcm%n_mci = count (pcm%component_active)
allocate (pcm%i_mci (pcm%n_components), source = 0)
i_mci = 0
do i = 1, pcm%n_components
if (pcm%component_active(i)) then
i_mci = i_mci + 1
pcm%i_mci(i) = i_mci
end if
end do
allocate (mci_entry (pcm%n_mci))
end subroutine pcm_default_setup_mci
module subroutine pcm_default_call_dispatch_mci (pcm, &
dispatch_mci, var_list, process_id, mci_template)
class(pcm_default_t), intent(inout) :: pcm
procedure(dispatch_mci_proc) :: dispatch_mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
class(mci_t), allocatable, intent(out) :: mci_template
call dispatch_mci (mci_template, var_list, process_id)
end subroutine pcm_default_call_dispatch_mci
@ %def pcm_default_setup_mci
@ %def pcm_default_call_dispatch_mci
@ Nothing left to do for the default algorithm.
<<PCM: pcm default: TBP>>=
procedure :: complete_setup => pcm_default_complete_setup
<<PCM: sub interfaces>>=
module subroutine pcm_default_complete_setup &
(pcm, core_entry, component, model)
class(pcm_default_t), intent(inout) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
type(process_component_t), dimension(:), intent(inout) :: component
type(model_t), intent(in), target :: model
end subroutine pcm_default_complete_setup
<<PCM: procedures>>=
module subroutine pcm_default_complete_setup &
(pcm, core_entry, component, model)
class(pcm_default_t), intent(inout) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
type(process_component_t), dimension(:), intent(inout) :: component
type(model_t), intent(in), target :: model
end subroutine pcm_default_complete_setup
@ %def pcm_default_complete_setup
@
\subsubsection{Component management}
Initialize a single component. We require all process-configuration blocks,
and specific templates for the phase-space and integrator configuration.
We also provide the current component index [[i]] and the [[active]] flag.
In the default mode, all components are marked as master components.
<<PCM: pcm default: TBP>>=
procedure :: init_component => pcm_default_init_component
<<PCM: sub interfaces>>=
module subroutine pcm_default_init_component (pcm, component, i, active, &
phs_config, env, meta, config)
class(pcm_default_t), intent(in) :: pcm
type(process_component_t), intent(out) :: component
integer, intent(in) :: i
logical, intent(in) :: active
class(phs_config_t), allocatable, intent(in) :: phs_config
type(process_environment_t), intent(in) :: env
type(process_metadata_t), intent(in) :: meta
type(process_config_data_t), intent(in) :: config
end subroutine pcm_default_init_component
<<PCM: procedures>>=
module subroutine pcm_default_init_component (pcm, component, i, active, &
phs_config, env, meta, config)
class(pcm_default_t), intent(in) :: pcm
type(process_component_t), intent(out) :: component
integer, intent(in) :: i
logical, intent(in) :: active
class(phs_config_t), allocatable, intent(in) :: phs_config
type(process_environment_t), intent(in) :: env
type(process_metadata_t), intent(in) :: meta
type(process_config_data_t), intent(in) :: config
call component%init (i, &
env, meta, config, &
active, &
phs_config)
component%component_type = COMP_MASTER
end subroutine pcm_default_init_component
@ %def pcm_default_init_component
@
\subsection{NLO process component manager}
The NLO-aware version of the process-component manager.
This is the configuration object, which has the duty of allocating the
corresponding instance. This is the nontrivial NLO version.
<<PCM: public>>=
public :: pcm_nlo_t
<<PCM: types>>=
type, extends (pcm_t) :: pcm_nlo_t
type(string_t) :: id
logical :: combined_integration = .false.
logical :: vis_fks_regions = .false.
integer, dimension(:), allocatable :: nlo_type
integer, dimension(:), allocatable :: nlo_type_core
integer, dimension(:), allocatable :: component_type
integer :: i_born = 0
integer :: i_real = 0
integer :: i_sub = 0
type(nlo_settings_t) :: settings
type(region_data_t) :: region_data
logical :: use_real_partition = .false.
logical :: use_real_singular = .false.
real(default) :: real_partition_scale = 0
class(real_partition_t), allocatable :: real_partition
type(dalitz_plot_t) :: dalitz_plot
type(quantum_numbers_t), dimension(:,:), allocatable :: qn_real, qn_born
contains
<<PCM: pcm nlo: TBP>>
end type pcm_nlo_t
@ %def pcm_nlo_t
@
Initialize configuration data, using environment variables.
<<PCM: pcm nlo: TBP>>=
procedure :: init => pcm_nlo_init
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_init (pcm, env, meta)
class(pcm_nlo_t), intent(out) :: pcm
type(process_metadata_t), intent(in) :: meta
type(process_environment_t), intent(in) :: env
end subroutine pcm_nlo_init
<<PCM: procedures>>=
module subroutine pcm_nlo_init (pcm, env, meta)
class(pcm_nlo_t), intent(out) :: pcm
type(process_metadata_t), intent(in) :: meta
type(process_environment_t), intent(in) :: env
type(var_list_t), pointer :: var_list
type(fks_template_t) :: fks_template
pcm%id = meta%id
pcm%has_pdfs = env%has_pdfs ()
var_list => env%get_var_list_ptr ()
call dispatch_fks_setup (fks_template, var_list)
call pcm%settings%init (var_list, fks_template)
pcm%combined_integration = &
var_list%get_lval (var_str ('?combined_nlo_integration'))
select case (char (var_list%get_sval (var_str ("$real_partition_mode"))))
case ("default", "off")
pcm%use_real_partition = .false.
pcm%use_real_singular = .false.
case ("all", "on", "singular")
pcm%use_real_partition = .true.
pcm%use_real_singular = .true.
case ("finite")
pcm%use_real_partition = .true.
pcm%use_real_singular = .false.
case default
call msg_fatal ("The real partition mode can only be " // &
"default, off, all, on, singular or finite.")
end select
pcm%real_partition_scale = &
var_list%get_rval (var_str ("real_partition_scale"))
pcm%vis_fks_regions = &
var_list%get_lval (var_str ("?vis_fks_regions"))
call pcm%set_blha_defaults &
(env%has_polarized_beams (), env%get_var_list_ptr ())
pcm%os_data = env%get_os_data ()
end subroutine pcm_nlo_init
@ %def pcm_nlo_init
@ Init/rewrite NLO settings without the FKS template.
<<PCM: pcm nlo: TBP>>=
procedure :: init_nlo_settings => pcm_nlo_init_nlo_settings
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_init_nlo_settings (pcm, var_list)
class(pcm_nlo_t), intent(inout) :: pcm
type(var_list_t), intent(in), target :: var_list
end subroutine pcm_nlo_init_nlo_settings
<<PCM: procedures>>=
module subroutine pcm_nlo_init_nlo_settings (pcm, var_list)
class(pcm_nlo_t), intent(inout) :: pcm
type(var_list_t), intent(in), target :: var_list
call pcm%settings%init (var_list)
end subroutine pcm_nlo_init_nlo_settings
@ %def pcm_nlo_init_nlo_settings
@
As appropriate for the NLO/FKS algorithm, the category defined by the
process, is called [[nlo_type]]. We refine this by setting the component
category [[component_type]] separately.
The component types [[COMP_MISMATCH]], [[COMP_PDF]], [[COMP_SUB]] are set only
if the algorithm uses combined integration. Otherwise, they are set to
[[COMP_DEFAULT]].
The component type [[COMP_REAL]] is further distinguished between
[[COMP_REAL_SING]] or [[COMP_REAL_FIN]], if the algorithm uses real
partitions. The former acts as a reference component for the latter, and we
always assume that it is the first real component.
Each component is assigned its own core. Exceptions: the finite-real
component gets the same core as the singular-real component. The mismatch
component gets the same core as the subtraction component.
TODO wk 2018: this convention for real components can be improved.
Check whether all component types should be assigned, not just for combined
integration.
<<PCM: pcm nlo: TBP>>=
procedure :: categorize_components => pcm_nlo_categorize_components
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_categorize_components (pcm, config)
class(pcm_nlo_t), intent(inout) :: pcm
type(process_config_data_t), intent(in) :: config
end subroutine pcm_nlo_categorize_components
<<PCM: procedures>>=
module subroutine pcm_nlo_categorize_components (pcm, config)
class(pcm_nlo_t), intent(inout) :: pcm
type(process_config_data_t), intent(in) :: config
type(process_component_def_t), pointer :: component_def
integer :: i
allocate (pcm%nlo_type (pcm%n_components), source = COMPONENT_UNDEFINED)
allocate (pcm%component_type (pcm%n_components), source = COMP_DEFAULT)
do i = 1, pcm%n_components
component_def => config%process_def%get_component_def_ptr (i)
pcm%nlo_type(i) = component_def%get_nlo_type ()
if (pcm%combined_integration) then
select case (pcm%nlo_type(i))
case (BORN)
pcm%i_born = i
pcm%component_type(i) = COMP_MASTER
case (NLO_REAL)
pcm%component_type(i) = COMP_REAL
case (NLO_VIRTUAL)
pcm%component_type(i) = COMP_VIRT
case (NLO_MISMATCH)
pcm%component_type(i) = COMP_MISMATCH
case (NLO_DGLAP)
pcm%component_type(i) = COMP_PDF
case (NLO_SUBTRACTION)
pcm%component_type(i) = COMP_SUB
pcm%i_sub = i
end select
else
select case (pcm%nlo_type(i))
case (BORN)
pcm%i_born = i
pcm%component_type(i) = COMP_MASTER
case (NLO_REAL)
pcm%component_type(i) = COMP_REAL
case (NLO_VIRTUAL)
pcm%component_type(i) = COMP_VIRT
case (NLO_MISMATCH)
pcm%component_type(i) = COMP_MISMATCH
case (NLO_SUBTRACTION)
pcm%i_sub = i
end select
end if
end do
call refine_real_type ( &
pack ([(i, i=1, pcm%n_components)], &
pcm%component_type==COMP_REAL))
contains
subroutine refine_real_type (i_real)
integer, dimension(:), intent(in) :: i_real
pcm%i_real = i_real(1)
if (pcm%use_real_partition) then
pcm%component_type (i_real(1)) = COMP_REAL_SING
pcm%component_type (i_real(2:)) = COMP_REAL_FIN
end if
end subroutine refine_real_type
end subroutine pcm_nlo_categorize_components
@ %def pcm_nlo_categorize_components
@
\subsubsection{Phase-space initial configuration}
Setup for the NLO/PHS processes: two phase-space configurations, (1)
Born/wood, (2) real correction/FKS. All components use either one of these
two configurations.
TODO wk 2018: The [[first_real_component]] identifier is really ugly.
Nothing should rely on the ordering.
<<PCM: pcm nlo: TBP>>=
procedure :: init_phs_config => pcm_nlo_init_phs_config
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_init_phs_config &
(pcm, phs_entry, meta, env, phs_par, mapping_defs)
class(pcm_nlo_t), intent(inout) :: pcm
type(process_phs_config_t), &
dimension(:), allocatable, intent(out) :: phs_entry
type(process_metadata_t), intent(in) :: meta
type(process_environment_t), intent(in) :: env
type(mapping_defaults_t), intent(in) :: mapping_defs
type(phs_parameters_t), intent(in) :: phs_par
end subroutine pcm_nlo_init_phs_config
<<PCM: procedures>>=
module subroutine pcm_nlo_init_phs_config &
(pcm, phs_entry, meta, env, phs_par, mapping_defs)
class(pcm_nlo_t), intent(inout) :: pcm
type(process_phs_config_t), &
dimension(:), allocatable, intent(out) :: phs_entry
type(process_metadata_t), intent(in) :: meta
type(process_environment_t), intent(in) :: env
type(mapping_defaults_t), intent(in) :: mapping_defs
type(phs_parameters_t), intent(in) :: phs_par
integer :: i
logical :: first_real_component
allocate (phs_entry (2))
call dispatch_phs (phs_entry(1)%phs_config, &
env%get_var_list_ptr (), &
env%get_os_data (), &
meta%id, &
mapping_defs, phs_par, &
var_str ("wood"))
call dispatch_phs (phs_entry(2)%phs_config, &
env%get_var_list_ptr (), &
env%get_os_data (), &
meta%id, &
mapping_defs, phs_par, &
var_str ("fks"))
allocate (pcm%i_phs_config (pcm%n_components), source=0)
first_real_component = .true.
do i = 1, pcm%n_components
select case (pcm%nlo_type(i))
case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION)
pcm%i_phs_config(i) = 1
case (NLO_REAL)
if (pcm%use_real_partition) then
if (pcm%use_real_singular) then
if (first_real_component) then
pcm%i_phs_config(i) = 2
first_real_component = .false.
else
pcm%i_phs_config(i) = 1
end if
else
pcm%i_phs_config(i) = 1
end if
else
pcm%i_phs_config(i) = 2
end if
case (NLO_MISMATCH, NLO_DGLAP, GKS)
pcm%i_phs_config(i) = 2
end select
end do
end subroutine pcm_nlo_init_phs_config
@ %def pcm_nlo_init_phs_config
@
\subsubsection{Core management}
Allocate the core (matrix-element interface) objects that we will need for
evaluation. Every component gets an associated core, except for the
real-finite and mismatch components (if any). Those components are associated
with their previous corresponding real-singular and subtraction cores,
respectively.
After cores are allocated, configure the region-data block that is maintained
by the NLO process-component manager.
<<PCM: pcm nlo: TBP>>=
procedure :: allocate_cores => pcm_nlo_allocate_cores
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_allocate_cores (pcm, config, core_entry)
class(pcm_nlo_t), intent(inout) :: pcm
type(process_config_data_t), intent(in) :: config
type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
end subroutine pcm_nlo_allocate_cores
<<PCM: procedures>>=
module subroutine pcm_nlo_allocate_cores (pcm, config, core_entry)
class(pcm_nlo_t), intent(inout) :: pcm
type(process_config_data_t), intent(in) :: config
type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
type(process_component_def_t), pointer :: component_def
integer :: i, i_core
allocate (pcm%i_core (pcm%n_components), source = 0)
pcm%n_cores = pcm%n_components &
- count (pcm%component_type(:) == COMP_REAL_FIN) &
- count (pcm%component_type(:) == COMP_MISMATCH)
allocate (core_entry (pcm%n_cores))
allocate (pcm%nlo_type_core (pcm%n_cores), source = BORN)
i_core = 0
do i = 1, pcm%n_components
select case (pcm%component_type(i))
case default
i_core = i_core + 1
pcm%i_core(i) = i_core
pcm%nlo_type_core(i_core) = pcm%nlo_type(i)
core_entry(i_core)%i_component = i
component_def => config%process_def%get_component_def_ptr (i)
core_entry(i_core)%core_def => component_def%get_core_def_ptr ()
select case (pcm%nlo_type(i))
case default
core_entry(i)%active = component_def%can_be_integrated ()
case (NLO_REAL, NLO_SUBTRACTION)
core_entry(i)%active = .true.
end select
case (COMP_REAL_FIN)
pcm%i_core(i) = pcm%i_core(pcm%i_real)
case (COMP_MISMATCH)
pcm%i_core(i) = pcm%i_core(pcm%i_sub)
end select
end do
end subroutine pcm_nlo_allocate_cores
@ %def pcm_nlo_allocate_cores
@ Extra code is required for certain core types (threshold) or if BLHA uses an
external OLP for getting its matrix elements. OMega matrix elements, by
definition, do not need extra code. NLO-virtual or subtraction
matrix elements always need extra code.
More precisely: for the Born and virtual matrix element, the extra code is
accessed only if the component is active. The radiation (real) and the
subtraction corrections (singular and finite), extra code is accessed in any
case.
The flavor state is taken from the [[region_data]] table in the [[pcm]]
record. We use the Born and real flavor-state tables as appropriate.
<<PCM: pcm nlo: TBP>>=
procedure :: prepare_any_external_code => &
pcm_nlo_prepare_any_external_code
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_prepare_any_external_code &
(pcm, core_entry, i_core, libname, model, var_list)
class(pcm_nlo_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
integer, intent(in) :: i_core
type(string_t), intent(in) :: libname
type(model_data_t), intent(in), target :: model
type(var_list_t), intent(in) :: var_list
end subroutine pcm_nlo_prepare_any_external_code
<<PCM: procedures>>=
module subroutine pcm_nlo_prepare_any_external_code &
(pcm, core_entry, i_core, libname, model, var_list)
class(pcm_nlo_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
integer, intent(in) :: i_core
type(string_t), intent(in) :: libname
type(model_data_t), intent(in), target :: model
type(var_list_t), intent(in) :: var_list
integer, dimension(:,:), allocatable :: flv_born, flv_real
integer :: i
call pcm%region_data%get_all_flv_states (flv_born, flv_real)
if (core_entry%active) then
associate (core => core_entry%core)
if (core%needs_external_code ()) then
select case (pcm%nlo_type (core_entry%i_component))
case default
call core%data%set_flv_state (flv_born)
case (NLO_REAL)
call core%data%set_flv_state (flv_real)
end select
call core%prepare_external_code &
(core%data%flv_state, &
var_list, pcm%os_data, libname, model, i_core, .true.)
end if
call core%set_equivalent_flv_hel_indices ()
end associate
end if
end subroutine pcm_nlo_prepare_any_external_code
@ %def pcm_nlo_prepare_any_external_code
@ Allocate and configure the BLHA record for a specific core, assuming that
the core type requires it. The configuration depends on the NLO type of the
core.
<<PCM: pcm nlo: TBP>>=
procedure :: setup_blha => pcm_nlo_setup_blha
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_setup_blha (pcm, core_entry)
class(pcm_nlo_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
end subroutine pcm_nlo_setup_blha
<<PCM: procedures>>=
module subroutine pcm_nlo_setup_blha (pcm, core_entry)
class(pcm_nlo_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
allocate (core_entry%blha_config, source = pcm%blha_defaults)
select case (pcm%nlo_type(core_entry%i_component))
case (BORN)
call core_entry%blha_config%set_born ()
case (NLO_REAL)
call core_entry%blha_config%set_real_trees ()
case (NLO_VIRTUAL)
call core_entry%blha_config%set_loop ()
case (NLO_SUBTRACTION)
call core_entry%blha_config%set_subtraction ()
call core_entry%blha_config%set_internal_color_correlations ()
case (NLO_DGLAP)
call core_entry%blha_config%set_dglap ()
end select
end subroutine pcm_nlo_setup_blha
@ %def pcm_nlo_setup_blha
@ After phase-space configuration data and core entries are available, we fill
tables and compute the remaining NLO data that will steer the integration
and subtraction algorithm.
There are three parts: recognize a threshold-type process core (if it exists),
prepare the region-data tables (always), and prepare for real partitioning (if
requested).
The real-component phase space acts as the source for resonance-history
information, required for the region data.
<<PCM: pcm nlo: TBP>>=
procedure :: complete_setup => pcm_nlo_complete_setup
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_complete_setup (pcm, core_entry, component, model)
class(pcm_nlo_t), intent(inout) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
type(process_component_t), dimension(:), intent(inout) :: component
type(model_t), intent(in), target :: model
end subroutine pcm_nlo_complete_setup
<<PCM: procedures>>=
module subroutine pcm_nlo_complete_setup (pcm, core_entry, component, model)
class(pcm_nlo_t), intent(inout) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
type(process_component_t), dimension(:), intent(inout) :: component
type(model_t), intent(in), target :: model
integer :: alpha_power, alphas_power
call pcm%handle_threshold_core (core_entry)
call component(1)%config%get_coupling_powers (alpha_power, alphas_power)
call pcm%setup_region_data (core_entry, &
- component(pcm%i_real)%phs_config, model, alpha_power, alphas_power)
+ model, alpha_power, alphas_power, component(pcm%i_real)%phs_config)
call pcm%setup_real_partition ()
end subroutine pcm_nlo_complete_setup
@ %def pcm_nlo_complete_setup
@ Apply the BLHA configuration to a core object, using the region data from
[[pcm]] for determining the particle content.
<<PCM: pcm nlo: TBP>>=
procedure :: prepare_blha_core => pcm_nlo_prepare_blha_core
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_prepare_blha_core (pcm, core_entry, model)
class(pcm_nlo_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
class(model_data_t), intent(in), target :: model
end subroutine pcm_nlo_prepare_blha_core
<<PCM: procedures>>=
module subroutine pcm_nlo_prepare_blha_core (pcm, core_entry, model)
class(pcm_nlo_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
class(model_data_t), intent(in), target :: model
integer :: n_in
integer :: n_legs
integer :: n_flv
integer :: n_hel
select type (core => core_entry%core)
class is (prc_blha_t)
associate (blha_config => core_entry%blha_config)
n_in = core%data%n_in
select case (pcm%nlo_type(core_entry%i_component))
case (NLO_REAL)
n_legs = pcm%region_data%get_n_legs_real ()
n_flv = pcm%region_data%get_n_flv_real ()
case default
n_legs = pcm%region_data%get_n_legs_born ()
n_flv = pcm%region_data%get_n_flv_born ()
end select
n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model)
call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel)
call core%init_driver (pcm%os_data)
end associate
end select
end subroutine pcm_nlo_prepare_blha_core
@ %def pcm_nlo_prepare_blha_core
@ Read the method settings from the variable list and store them in the BLHA
master. This version: NLO flag set.
<<PCM: pcm nlo: TBP>>=
procedure :: set_blha_methods => pcm_nlo_set_blha_methods
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_set_blha_methods (pcm, blha_master, var_list)
class(pcm_nlo_t), intent(inout) :: pcm
type(blha_master_t), intent(inout) :: blha_master
type(var_list_t), intent(in) :: var_list
end subroutine pcm_nlo_set_blha_methods
<<PCM: procedures>>=
module subroutine pcm_nlo_set_blha_methods (pcm, blha_master, var_list)
class(pcm_nlo_t), intent(inout) :: pcm
type(blha_master_t), intent(inout) :: blha_master
type(var_list_t), intent(in) :: var_list
call blha_master%set_methods (.true., var_list)
call pcm%blha_defaults%set_loop_method (blha_master)
end subroutine pcm_nlo_set_blha_methods
@ %def pcm_nlo_set_blha_methods
@ Produce the LO and NLO flavor-state tables (as far as available), as
appropriate for BLHA configuration.
The NLO version copies the tables from the region data inside [[pcm]]. The
core array is not needed.
<<PCM: pcm nlo: TBP>>=
procedure :: get_blha_flv_states => pcm_nlo_get_blha_flv_states
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_get_blha_flv_states &
(pcm, core_entry, flv_born, flv_real)
class(pcm_nlo_t), intent(in) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
integer, dimension(:,:), allocatable, intent(out) :: flv_born
integer, dimension(:,:), allocatable, intent(out) :: flv_real
end subroutine pcm_nlo_get_blha_flv_states
<<PCM: procedures>>=
module subroutine pcm_nlo_get_blha_flv_states &
(pcm, core_entry, flv_born, flv_real)
class(pcm_nlo_t), intent(in) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
integer, dimension(:,:), allocatable, intent(out) :: flv_born
integer, dimension(:,:), allocatable, intent(out) :: flv_real
call pcm%region_data%get_all_flv_states (flv_born, flv_real)
end subroutine pcm_nlo_get_blha_flv_states
@ %def pcm_nlo_get_blha_flv_states
@ Allocate and configure the MCI (multi-channel integrator) records. The
relation depends on the [[combined_integration]] setting. If we integrate
components separately, each component gets its own record, except for the
subtraction component. If we do the combination, there is one record for
the master (Born) component and a second one for the real-finite component,
if present.
Each entry acquires some NLO-specific initialization. Generic configuration
follows later.
Second procedure: call the MCI dispatcher with NLO-setup arguments.
<<PCM: pcm nlo: TBP>>=
procedure :: setup_mci => pcm_nlo_setup_mci
procedure :: call_dispatch_mci => pcm_nlo_call_dispatch_mci
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_setup_mci (pcm, mci_entry)
class(pcm_nlo_t), intent(inout) :: pcm
type(process_mci_entry_t), &
dimension(:), allocatable, intent(out) :: mci_entry
end subroutine pcm_nlo_setup_mci
module subroutine pcm_nlo_call_dispatch_mci (pcm, &
dispatch_mci, var_list, process_id, mci_template)
class(pcm_nlo_t), intent(inout) :: pcm
procedure(dispatch_mci_proc) :: dispatch_mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
class(mci_t), allocatable, intent(out) :: mci_template
end subroutine pcm_nlo_call_dispatch_mci
<<PCM: procedures>>=
module subroutine pcm_nlo_setup_mci (pcm, mci_entry)
class(pcm_nlo_t), intent(inout) :: pcm
type(process_mci_entry_t), &
dimension(:), allocatable, intent(out) :: mci_entry
class(mci_t), allocatable :: mci_template
integer :: i, i_mci
if (pcm%combined_integration) then
pcm%n_mci = 1 &
+ count (pcm%component_active(:) &
& .and. pcm%component_type(:) == COMP_REAL_FIN)
allocate (pcm%i_mci (pcm%n_components), source = 0)
do i = 1, pcm%n_components
if (pcm%component_active(i)) then
select case (pcm%component_type(i))
case (COMP_MASTER)
pcm%i_mci(i) = 1
case (COMP_REAL_FIN)
pcm%i_mci(i) = 2
end select
end if
end do
else
pcm%n_mci = count (pcm%component_active(:) &
& .and. pcm%nlo_type(:) /= NLO_SUBTRACTION)
allocate (pcm%i_mci (pcm%n_components), source = 0)
i_mci = 0
do i = 1, pcm%n_components
if (pcm%component_active(i)) then
select case (pcm%nlo_type(i))
case default
i_mci = i_mci + 1
pcm%i_mci(i) = i_mci
case (NLO_SUBTRACTION)
end select
end if
end do
end if
allocate (mci_entry (pcm%n_mci))
mci_entry(:)%combined_integration = pcm%combined_integration
if (pcm%use_real_partition) then
do i = 1, pcm%n_components
i_mci = pcm%i_mci(i)
if (i_mci > 0) then
select case (pcm%component_type(i))
case (COMP_REAL_FIN)
mci_entry(i_mci)%real_partition_type = REAL_FINITE
case default
mci_entry(i_mci)%real_partition_type = REAL_SINGULAR
end select
end if
end do
end if
end subroutine pcm_nlo_setup_mci
module subroutine pcm_nlo_call_dispatch_mci (pcm, &
dispatch_mci, var_list, process_id, mci_template)
class(pcm_nlo_t), intent(inout) :: pcm
procedure(dispatch_mci_proc) :: dispatch_mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
class(mci_t), allocatable, intent(out) :: mci_template
call dispatch_mci (mci_template, var_list, process_id, is_nlo = .true.)
end subroutine pcm_nlo_call_dispatch_mci
@ %def pcm_nlo_setup_mci
@ %def pcm_nlo_call_dispatch_mci
@ Check for a threshold core and adjust the configuration accordingly, before
singular region data are considered.
<<PCM: pcm nlo: TBP>>=
procedure :: handle_threshold_core => pcm_nlo_handle_threshold_core
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_handle_threshold_core (pcm, core_entry)
class(pcm_nlo_t), intent(inout) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
end subroutine pcm_nlo_handle_threshold_core
<<PCM: procedures>>=
module subroutine pcm_nlo_handle_threshold_core (pcm, core_entry)
class(pcm_nlo_t), intent(inout) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
integer :: i
do i = 1, size (core_entry)
select type (core => core_entry(i)%core_def)
type is (threshold_def_t)
pcm%settings%factorization_mode = FACTORIZATION_THRESHOLD
return
end select
end do
end subroutine pcm_nlo_handle_threshold_core
@ %def pcm_nlo_handle_threshold_core
@ Configure the singular-region tables based on the process data for the Born
and Real (singular) cores, using also the appropriate FKS phase-space
configuration object.
In passing, we may create a table of resonance histories that are relevant for
the singular-region configuration.
TODO wk 2018: check whether [[phs_entry]] needs to be intent(inout).
<<PCM: pcm nlo: TBP>>=
procedure :: setup_region_data => pcm_nlo_setup_region_data
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_setup_region_data &
- (pcm, core_entry, phs_config, model, alpha_power, alphas_power)
+ (pcm, core_entry, model, alpha_power, alphas_power, phs_config)
class(pcm_nlo_t), intent(inout) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
- class(phs_config_t), intent(inout) :: phs_config
type(model_t), intent(in), target :: model
integer, intent(in) :: alpha_power, alphas_power
+ class(phs_config_t), intent(inout), optional :: phs_config
end subroutine pcm_nlo_setup_region_data
<<PCM: procedures>>=
module subroutine pcm_nlo_setup_region_data &
- (pcm, core_entry, phs_config, model, alpha_power, alphas_power)
+ (pcm, core_entry, model, alpha_power, alphas_power, phs_config)
class(pcm_nlo_t), intent(inout) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
- class(phs_config_t), intent(inout) :: phs_config
type(model_t), intent(in), target :: model
integer, intent(in) :: alpha_power, alphas_power
+ class(phs_config_t), intent(inout), optional :: phs_config
type(process_constants_t) :: data_born, data_real
integer, dimension (:,:), allocatable :: flavor_born, flavor_real
type(resonance_history_t), dimension(:), allocatable :: resonance_histories
type(var_list_t), pointer :: var_list
logical :: success
data_born = core_entry(pcm%i_core(pcm%i_born))%core%data
data_real = core_entry(pcm%i_core(pcm%i_real))%core%data
call data_born%get_flv_state (flavor_born)
call data_real%get_flv_state (flavor_real)
call pcm%region_data%init &
(data_born%n_in, model, flavor_born, flavor_real, &
pcm%settings%nlo_correction_type, alpha_power, alphas_power)
associate (template => pcm%settings%fks_template)
if (template%mapping_type == FKS_RESONANCES) then
+ if (.not. present(phs_config)) then
+ call msg_bug("setup_region_data: real phase space required to setup the resonance histories.")
+ end if
select type (phs_config)
type is (phs_fks_config_t)
call get_filtered_resonance_histories (phs_config, &
data_born%n_in, flavor_born, model, &
template%excluded_resonances, &
resonance_histories, success)
end select
if (.not. success) template%mapping_type = FKS_DEFAULT
end if
call pcm%region_data%setup_fks_mappings (template, data_born%n_in)
!!! Check again, mapping_type might have changed
if (template%mapping_type == FKS_RESONANCES) then
call pcm%region_data%set_resonance_mappings (resonance_histories)
call pcm%region_data%init_resonance_information ()
pcm%settings%use_resonance_mappings = .true.
end if
end associate
if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
call pcm%region_data%set_isr_pseudo_regions ()
call pcm%region_data%split_up_interference_regions_for_threshold ()
end if
call pcm%region_data%compute_number_of_phase_spaces ()
call pcm%region_data%set_i_phs_to_i_con ()
call pcm%region_data%write_to_file &
(pcm%id, pcm%vis_fks_regions, pcm%os_data)
if (debug_active (D_SUBTRACTION)) &
call pcm%region_data%check_consistency (.true.)
end subroutine pcm_nlo_setup_region_data
@ %def pcm_nlo_setup_region_data
@ After region data are set up, we allocate and configure the
[[real_partition]] objects, if requested.
Gfortran 7/8/9 bug, has to remain in the main module:
<<PCM: pcm nlo: TBP>>=
procedure :: setup_real_partition => pcm_nlo_setup_real_partition
<<PCM: main procedures>>=
subroutine pcm_nlo_setup_real_partition (pcm)
class(pcm_nlo_t), intent(inout) :: pcm
if (pcm%use_real_partition) then
if (.not. allocated (pcm%real_partition)) then
allocate (real_partition_fixed_order_t :: pcm%real_partition)
select type (partition => pcm%real_partition)
type is (real_partition_fixed_order_t)
call pcm%region_data%get_all_ftuples (partition%fks_pairs)
partition%scale = pcm%real_partition_scale
end select
end if
end if
end subroutine pcm_nlo_setup_real_partition
@ %def pcm_nlo_setup_real_partition
@
Initialize a single component. We require all process-configuration blocks,
and specific templates for the phase-space and integrator configuration.
We also provide the current component index [[i]] and the [[active]] flag.
For a subtraction component, the [[active]] flag is overridden.
In the nlo mode, the component types have been determined before.
TODO wk 2018: the component type need not be stored in the component; we may remove
this when everything is controlled by [[pcm]].
<<PCM: pcm nlo: TBP>>=
procedure :: init_component => pcm_nlo_init_component
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_init_component (pcm, component, i, active, &
phs_config, env, meta, config)
class(pcm_nlo_t), intent(in) :: pcm
type(process_component_t), intent(out) :: component
integer, intent(in) :: i
logical, intent(in) :: active
class(phs_config_t), allocatable, intent(in) :: phs_config
type(process_environment_t), intent(in) :: env
type(process_metadata_t), intent(in) :: meta
type(process_config_data_t), intent(in) :: config
end subroutine pcm_nlo_init_component
<<PCM: procedures>>=
module subroutine pcm_nlo_init_component (pcm, component, i, active, &
phs_config, env, meta, config)
class(pcm_nlo_t), intent(in) :: pcm
type(process_component_t), intent(out) :: component
integer, intent(in) :: i
logical, intent(in) :: active
class(phs_config_t), allocatable, intent(in) :: phs_config
type(process_environment_t), intent(in) :: env
type(process_metadata_t), intent(in) :: meta
type(process_config_data_t), intent(in) :: config
logical :: activate
select case (pcm%nlo_type(i))
case default; activate = active
case (NLO_SUBTRACTION); activate = .false.
end select
call component%init (i, &
env, meta, config, &
activate, &
phs_config)
component%component_type = pcm%component_type(i)
end subroutine pcm_nlo_init_component
@ %def pcm_nlo_init_component
@
Override the base method: record the active components in the PCM object, and
report inactive components (except for the subtraction component).
<<PCM: pcm nlo: TBP>>=
procedure :: record_inactive_components => pcm_nlo_record_inactive_components
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_record_inactive_components (pcm, component, meta)
class(pcm_nlo_t), intent(inout) :: pcm
type(process_component_t), dimension(:), intent(in) :: component
type(process_metadata_t), intent(inout) :: meta
end subroutine pcm_nlo_record_inactive_components
<<PCM: procedures>>=
module subroutine pcm_nlo_record_inactive_components (pcm, component, meta)
class(pcm_nlo_t), intent(inout) :: pcm
type(process_component_t), dimension(:), intent(in) :: component
type(process_metadata_t), intent(inout) :: meta
integer :: i
pcm%component_active = component%active
do i = 1, pcm%n_components
select case (pcm%nlo_type(i))
case (NLO_SUBTRACTION)
case default
if (.not. component(i)%active) call meta%deactivate_component (i)
end select
end do
end subroutine pcm_nlo_record_inactive_components
@ %def pcm_nlo_record_inactive_components
@
<<PCM: pcm nlo: TBP>>=
procedure :: core_is_radiation => pcm_nlo_core_is_radiation
<<PCM: sub interfaces>>=
module function pcm_nlo_core_is_radiation (pcm, i_core) result (is_rad)
logical :: is_rad
class(pcm_nlo_t), intent(in) :: pcm
integer, intent(in) :: i_core
end function pcm_nlo_core_is_radiation
<<PCM: procedures>>=
module function pcm_nlo_core_is_radiation (pcm, i_core) result (is_rad)
logical :: is_rad
class(pcm_nlo_t), intent(in) :: pcm
integer, intent(in) :: i_core
is_rad = pcm%nlo_type(i_core) == NLO_REAL ! .and. .not. pcm%cm%sub(i_core)
end function pcm_nlo_core_is_radiation
@ %def pcm_nlo_core_is_radiation
@
<<PCM: pcm nlo: TBP>>=
procedure :: get_n_flv_born => pcm_nlo_get_n_flv_born
<<PCM: sub interfaces>>=
module function pcm_nlo_get_n_flv_born (pcm_nlo) result (n_flv)
integer :: n_flv
class(pcm_nlo_t), intent(in) :: pcm_nlo
end function pcm_nlo_get_n_flv_born
<<PCM: procedures>>=
module function pcm_nlo_get_n_flv_born (pcm_nlo) result (n_flv)
integer :: n_flv
class(pcm_nlo_t), intent(in) :: pcm_nlo
n_flv = pcm_nlo%region_data%n_flv_born
end function pcm_nlo_get_n_flv_born
@ %def pcm_nlo_get_n_flv_born
@
<<PCM: pcm nlo: TBP>>=
procedure :: get_n_flv_real => pcm_nlo_get_n_flv_real
<<PCM: sub interfaces>>=
module function pcm_nlo_get_n_flv_real (pcm_nlo) result (n_flv)
integer :: n_flv
class(pcm_nlo_t), intent(in) :: pcm_nlo
end function pcm_nlo_get_n_flv_real
<<PCM: procedures>>=
module function pcm_nlo_get_n_flv_real (pcm_nlo) result (n_flv)
integer :: n_flv
class(pcm_nlo_t), intent(in) :: pcm_nlo
n_flv = pcm_nlo%region_data%n_flv_real
end function pcm_nlo_get_n_flv_real
@ %def pcm_nlo_get_n_flv_real
@
<<PCM: pcm nlo: TBP>>=
procedure :: get_n_alr => pcm_nlo_get_n_alr
<<PCM: sub interfaces>>=
module function pcm_nlo_get_n_alr (pcm) result (n_alr)
integer :: n_alr
class(pcm_nlo_t), intent(in) :: pcm
end function pcm_nlo_get_n_alr
<<PCM: procedures>>=
module function pcm_nlo_get_n_alr (pcm) result (n_alr)
integer :: n_alr
class(pcm_nlo_t), intent(in) :: pcm
n_alr = pcm%region_data%n_regions
end function pcm_nlo_get_n_alr
@ %def pcm_nlo_get_n_alr
@
<<PCM: pcm nlo: TBP>>=
procedure :: get_flv_states => pcm_nlo_get_flv_states
<<PCM: sub interfaces>>=
module function pcm_nlo_get_flv_states (pcm, born) result (flv)
integer, dimension(:,:), allocatable :: flv
class(pcm_nlo_t), intent(in) :: pcm
logical, intent(in) :: born
end function pcm_nlo_get_flv_states
<<PCM: procedures>>=
module function pcm_nlo_get_flv_states (pcm, born) result (flv)
integer, dimension(:,:), allocatable :: flv
class(pcm_nlo_t), intent(in) :: pcm
logical, intent(in) :: born
if (born) then
flv = pcm%region_data%get_flv_states_born ()
else
flv = pcm%region_data%get_flv_states_real ()
end if
end function pcm_nlo_get_flv_states
@ %def pcm_nlo_get_flv_states
@
<<PCM: pcm nlo: TBP>>=
procedure :: get_qn => pcm_nlo_get_qn
<<PCM: sub interfaces>>=
module function pcm_nlo_get_qn (pcm, born) result (qn)
type(quantum_numbers_t), dimension(:,:), allocatable :: qn
class(pcm_nlo_t), intent(in) :: pcm
logical, intent(in) :: born
end function pcm_nlo_get_qn
<<PCM: procedures>>=
module function pcm_nlo_get_qn (pcm, born) result (qn)
type(quantum_numbers_t), dimension(:,:), allocatable :: qn
class(pcm_nlo_t), intent(in) :: pcm
logical, intent(in) :: born
if (born) then
qn = pcm%qn_born
else
qn = pcm%qn_real
end if
end function pcm_nlo_get_qn
@ %def pcm_nlo_get_qn
@ Check if there are massive emitters. Since the mass-structure of all
underlying Born configurations have to be the same (\textbf{This does
not have to be the case when different components are generated at LO})
, we just use the first one to determine this.
<<PCM: pcm nlo: TBP>>=
procedure :: has_massive_emitter => pcm_nlo_has_massive_emitter
<<PCM: sub interfaces>>=
module function pcm_nlo_has_massive_emitter (pcm) result (val)
logical :: val
class(pcm_nlo_t), intent(in) :: pcm
end function pcm_nlo_has_massive_emitter
<<PCM: procedures>>=
module function pcm_nlo_has_massive_emitter (pcm) result (val)
logical :: val
class(pcm_nlo_t), intent(in) :: pcm
integer :: i
val = .false.
associate (reg_data => pcm%region_data)
do i = reg_data%n_in + 1, reg_data%n_legs_born
if (any (i == reg_data%emitters)) &
val = val .or. reg_data%flv_born(1)%massive(i)
end do
end associate
end function pcm_nlo_has_massive_emitter
@ %def pcm_nlo_has_massive_emitter
@ Returns an array which specifies if the particle at position [[i]] is massive.
<<PCM: pcm nlo: TBP>>=
procedure :: get_mass_info => pcm_nlo_get_mass_info
<<PCM: sub interfaces>>=
module function pcm_nlo_get_mass_info (pcm, i_flv) result (massive)
class(pcm_nlo_t), intent(in) :: pcm
integer, intent(in) :: i_flv
logical, dimension(:), allocatable :: massive
end function pcm_nlo_get_mass_info
<<PCM: procedures>>=
module function pcm_nlo_get_mass_info (pcm, i_flv) result (massive)
class(pcm_nlo_t), intent(in) :: pcm
integer, intent(in) :: i_flv
logical, dimension(:), allocatable :: massive
allocate (massive (size (pcm%region_data%flv_born(i_flv)%massive)))
massive = pcm%region_data%flv_born(i_flv)%massive
end function pcm_nlo_get_mass_info
@ %def pcm_nlo_get_mass_info
@ Gfortran 7/8/9 bug, has to remain in the main module:
<<PCM: pcm nlo: TBP>>=
procedure :: allocate_workspace => pcm_nlo_allocate_workspace
<<PCM: main procedures>>=
subroutine pcm_nlo_allocate_workspace (pcm, work)
class(pcm_nlo_t), intent(in) :: pcm
class(pcm_workspace_t), intent(inout), allocatable :: work
allocate (pcm_nlo_workspace_t :: work)
end subroutine pcm_nlo_allocate_workspace
@ %def pcm_nlo_allocate_workspace
@
<<PCM: pcm nlo: TBP>>=
procedure :: init_qn => pcm_nlo_init_qn
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_init_qn (pcm, model)
class(pcm_nlo_t), intent(inout) :: pcm
class(model_data_t), intent(in) :: model
end subroutine pcm_nlo_init_qn
<<PCM: procedures>>=
module subroutine pcm_nlo_init_qn (pcm, model)
class(pcm_nlo_t), intent(inout) :: pcm
class(model_data_t), intent(in) :: model
integer, dimension(:,:), allocatable :: flv_states
type(flavor_t), dimension(:), allocatable :: flv
integer :: i
type(quantum_numbers_t), dimension(:), allocatable :: qn
allocate (flv_states (pcm%region_data%n_legs_born, &
pcm%region_data%n_flv_born))
flv_states = pcm%get_flv_states (.true.)
allocate (pcm%qn_born (size (flv_states, dim = 1), &
size (flv_states, dim = 2)))
allocate (flv (size (flv_states, dim = 1)))
allocate (qn (size (flv_states, dim = 1)))
do i = 1, pcm%get_n_flv_born ()
call flv%init (flv_states (:,i), model)
call qn%init (flv)
pcm%qn_born(:,i) = qn
end do
deallocate (flv); deallocate (qn)
deallocate (flv_states)
allocate (flv_states (pcm%region_data%n_legs_real, pcm%region_data%n_flv_real))
flv_states = pcm%get_flv_states (.false.)
allocate (pcm%qn_real (size (flv_states, dim = 1), size (flv_states, dim = 2)))
allocate (flv (size (flv_states, dim = 1)))
allocate (qn (size (flv_states, dim = 1)))
do i = 1, pcm%get_n_flv_real ()
call flv%init (flv_states (:,i), model)
call qn%init (flv)
pcm%qn_real(:,i) = qn
end do
end subroutine pcm_nlo_init_qn
@ %def pcm_nlo_init_qn
@ Gfortran 7/8/9 bug, has to remain in the main module:
<<PCM: pcm nlo: TBP>>=
procedure :: allocate_ps_matching => pcm_nlo_allocate_ps_matching
<<PCM: main procedures>>=
subroutine pcm_nlo_allocate_ps_matching (pcm)
class(pcm_nlo_t), intent(inout) :: pcm
if (.not. allocated (pcm%real_partition)) then
allocate (powheg_damping_simple_t :: pcm%real_partition)
end if
end subroutine pcm_nlo_allocate_ps_matching
@ %def pcm_nlo_allocate_ps_matching
@
<<PCM: pcm nlo: TBP>>=
procedure :: activate_dalitz_plot => pcm_nlo_activate_dalitz_plot
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_activate_dalitz_plot (pcm, filename)
class(pcm_nlo_t), intent(inout) :: pcm
type(string_t), intent(in) :: filename
end subroutine pcm_nlo_activate_dalitz_plot
<<PCM: procedures>>=
module subroutine pcm_nlo_activate_dalitz_plot (pcm, filename)
class(pcm_nlo_t), intent(inout) :: pcm
type(string_t), intent(in) :: filename
call pcm%dalitz_plot%init (free_unit (), filename, .false.)
call pcm%dalitz_plot%write_header ()
end subroutine pcm_nlo_activate_dalitz_plot
@ %def pcm_nlo_activate_dalitz_plot
@
<<PCM: pcm nlo: TBP>>=
procedure :: register_dalitz_plot => pcm_nlo_register_dalitz_plot
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_register_dalitz_plot (pcm, emitter, p)
class(pcm_nlo_t), intent(inout) :: pcm
integer, intent(in) :: emitter
type(vector4_t), intent(in), dimension(:) :: p
end subroutine pcm_nlo_register_dalitz_plot
<<PCM: procedures>>=
module subroutine pcm_nlo_register_dalitz_plot (pcm, emitter, p)
class(pcm_nlo_t), intent(inout) :: pcm
integer, intent(in) :: emitter
type(vector4_t), intent(in), dimension(:) :: p
real(default) :: k0_n, k0_np1
k0_n = p(emitter)%p(0)
k0_np1 = p(size(p))%p(0)
call pcm%dalitz_plot%register (k0_n, k0_np1)
end subroutine pcm_nlo_register_dalitz_plot
@ %def pcm_nlo_register_dalitz_plot
@
<<PCM: pcm nlo: TBP>>=
procedure :: setup_phs_generator => pcm_nlo_setup_phs_generator
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_setup_phs_generator (pcm, pcm_work, generator, &
sqrts, mode, singular_jacobian)
class(pcm_nlo_t), intent(in) :: pcm
type(phs_fks_generator_t), intent(inout) :: generator
type(pcm_nlo_workspace_t), intent(in), target :: pcm_work
real(default), intent(in) :: sqrts
integer, intent(in), optional:: mode
logical, intent(in), optional :: singular_jacobian
end subroutine pcm_nlo_setup_phs_generator
<<PCM: procedures>>=
module subroutine pcm_nlo_setup_phs_generator (pcm, pcm_work, generator, &
sqrts, mode, singular_jacobian)
class(pcm_nlo_t), intent(in) :: pcm
type(phs_fks_generator_t), intent(inout) :: generator
type(pcm_nlo_workspace_t), intent(in), target :: pcm_work
real(default), intent(in) :: sqrts
integer, intent(in), optional:: mode
logical, intent(in), optional :: singular_jacobian
logical :: yorn
yorn = .false.; if (present (singular_jacobian)) yorn = singular_jacobian
call generator%connect_kinematics (pcm_work%isr_kinematics, &
pcm_work%real_kinematics, pcm%has_massive_emitter ())
generator%n_in = pcm%region_data%n_in
call generator%set_sqrts_hat (sqrts)
call generator%set_emitters (pcm%region_data%emitters)
call generator%setup_masses (pcm%region_data%n_legs_born)
generator%is_massive = pcm%get_mass_info (1)
generator%singular_jacobian = yorn
if (present (mode)) generator%mode = mode
call generator%set_xi_and_y_bounds (pcm%settings%fks_template%xi_min, &
pcm%settings%fks_template%y_max)
end subroutine pcm_nlo_setup_phs_generator
@ %def pcm_nlo_setup_phs_generator
@
<<PCM: pcm nlo: TBP>>=
procedure :: final => pcm_nlo_final
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_final (pcm)
class(pcm_nlo_t), intent(inout) :: pcm
end subroutine pcm_nlo_final
<<PCM: procedures>>=
module subroutine pcm_nlo_final (pcm)
class(pcm_nlo_t), intent(inout) :: pcm
if (allocated (pcm%real_partition)) deallocate (pcm%real_partition)
call pcm%dalitz_plot%final ()
end subroutine pcm_nlo_final
@ %def pcm_nlo_final
@
<<PCM: pcm nlo: TBP>>=
procedure :: is_nlo => pcm_nlo_is_nlo
<<PCM: sub interfaces>>=
module function pcm_nlo_is_nlo (pcm) result (is_nlo)
logical :: is_nlo
class(pcm_nlo_t), intent(in) :: pcm
end function pcm_nlo_is_nlo
<<PCM: procedures>>=
module function pcm_nlo_is_nlo (pcm) result (is_nlo)
logical :: is_nlo
class(pcm_nlo_t), intent(in) :: pcm
is_nlo = .true.
end function pcm_nlo_is_nlo
@ %def pcm_nlo_is_nlo
@ As a first implementation, it acts as a wrapper for the NLO controller
object and the squared matrix-element collector.
<<PCM: public>>=
public :: pcm_nlo_workspace_t
<<PCM: types>>=
type, extends (pcm_workspace_t) :: pcm_nlo_workspace_t
type(real_kinematics_t), pointer :: real_kinematics => null ()
type(isr_kinematics_t), pointer :: isr_kinematics => null ()
type(real_subtraction_t) :: real_sub
type(virtual_t) :: virtual
type(soft_mismatch_t) :: soft_mismatch
type(dglap_remnant_t) :: dglap_remnant
integer, dimension(:), allocatable :: i_mci_to_real_component
contains
<<PCM: pcm instance: TBP>>
end type pcm_nlo_workspace_t
@ %def pcm_nlo_workspace_t
@
<<PCM: pcm instance: TBP>>=
procedure :: set_radiation_event => pcm_nlo_workspace_set_radiation_event
procedure :: set_subtraction_event => pcm_nlo_workspace_set_subtraction_event
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_set_radiation_event (pcm_work)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
end subroutine pcm_nlo_workspace_set_radiation_event
module subroutine pcm_nlo_workspace_set_subtraction_event (pcm_work)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
end subroutine pcm_nlo_workspace_set_subtraction_event
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_set_radiation_event (pcm_work)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
pcm_work%real_sub%radiation_event = .true.
pcm_work%real_sub%subtraction_event = .false.
end subroutine pcm_nlo_workspace_set_radiation_event
module subroutine pcm_nlo_workspace_set_subtraction_event (pcm_work)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
pcm_work%real_sub%radiation_event = .false.
pcm_work%real_sub%subtraction_event = .true.
end subroutine pcm_nlo_workspace_set_subtraction_event
@ %def pcm_nlo_workspace_set_radiation_event
@ %def pcm_nlo_workspace_set_subtraction_event
<<PCM: pcm instance: TBP>>=
procedure :: disable_subtraction => pcm_nlo_workspace_disable_subtraction
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_disable_subtraction (pcm_work)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
end subroutine pcm_nlo_workspace_disable_subtraction
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_disable_subtraction (pcm_work)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
pcm_work%real_sub%subtraction_deactivated = .true.
end subroutine pcm_nlo_workspace_disable_subtraction
@ %def pcm_nlo_workspace_disable_subtraction
@
<<PCM: pcm instance: TBP>>=
procedure :: init_config => pcm_nlo_workspace_init_config
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_init_config (pcm_work, pcm, &
active_components, nlo_types, energy, i_real_fin, model)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
logical, intent(in), dimension(:) :: active_components
integer, intent(in), dimension(:) :: nlo_types
real(default), intent(in), dimension(:) :: energy
integer, intent(in) :: i_real_fin
class(model_data_t), intent(in) :: model
end subroutine pcm_nlo_workspace_init_config
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_init_config (pcm_work, pcm, &
active_components, nlo_types, energy, i_real_fin, model)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
logical, intent(in), dimension(:) :: active_components
integer, intent(in), dimension(:) :: nlo_types
real(default), intent(in), dimension(:) :: energy
integer, intent(in) :: i_real_fin
class(model_data_t), intent(in) :: model
integer :: i_component
if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
"pcm_nlo_workspace_init_config")
call pcm_work%init_real_and_isr_kinematics (pcm, energy)
select type (pcm)
type is (pcm_nlo_t)
do i_component = 1, size (active_components)
if (active_components(i_component) .or. &
pcm%settings%combined_integration) then
select case (nlo_types(i_component))
case (NLO_REAL)
if (i_component /= i_real_fin) then
call pcm_work%setup_real_component (pcm, &
pcm%settings%fks_template%subtraction_disabled)
end if
case (NLO_VIRTUAL)
call pcm_work%init_virtual (pcm, model)
case (NLO_MISMATCH)
call pcm_work%init_soft_mismatch (pcm)
case (NLO_DGLAP)
call pcm_work%init_dglap_remnant (pcm)
end select
end if
end do
end select
end subroutine pcm_nlo_workspace_init_config
@ %def pcm_nlo_workspace_init_config
@
<<PCM: pcm instance: TBP>>=
procedure :: setup_real_component => pcm_nlo_workspace_setup_real_component
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_setup_real_component (pcm_work, pcm, &
subtraction_disabled)
class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
class(pcm_t), intent(in) :: pcm
logical, intent(in) :: subtraction_disabled
end subroutine pcm_nlo_workspace_setup_real_component
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_setup_real_component (pcm_work, pcm, &
subtraction_disabled)
class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
class(pcm_t), intent(in) :: pcm
logical, intent(in) :: subtraction_disabled
select type (pcm)
type is (pcm_nlo_t)
call pcm_work%init_real_subtraction (pcm)
if (subtraction_disabled) call pcm_work%disable_subtraction ()
end select
end subroutine pcm_nlo_workspace_setup_real_component
@ %def pcm_nlo_workspace_setup_real_component
@
<<PCM: pcm instance: TBP>>=
procedure :: init_real_and_isr_kinematics => &
pcm_nlo_workspace_init_real_and_isr_kinematics
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_init_real_and_isr_kinematics &
(pcm_work, pcm, energy)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
real(default), dimension(:), intent(in) :: energy
end subroutine pcm_nlo_workspace_init_real_and_isr_kinematics
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_init_real_and_isr_kinematics &
(pcm_work, pcm, energy)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
real(default), dimension(:), intent(in) :: energy
integer :: n_contr
allocate (pcm_work%real_kinematics)
allocate (pcm_work%isr_kinematics)
select type (pcm)
type is (pcm_nlo_t)
associate (region_data => pcm%region_data)
if (allocated (region_data%alr_contributors)) then
n_contr = size (region_data%alr_contributors)
else if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
n_contr = 2
else
n_contr = 1
end if
call pcm_work%real_kinematics%init &
(region_data%n_legs_real, region_data%n_phs, &
region_data%n_regions, n_contr)
if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) &
call pcm_work%real_kinematics%init_onshell &
(region_data%n_legs_real, region_data%n_phs)
pcm_work%isr_kinematics%n_in = region_data%n_in
end associate
end select
pcm_work%isr_kinematics%beam_energy = energy
end subroutine pcm_nlo_workspace_init_real_and_isr_kinematics
@ %def pcm_nlo_workspace_init_real_and_isr_kinematics
@
<<PCM: pcm instance: TBP>>=
procedure :: set_real_and_isr_kinematics => &
pcm_nlo_workspace_set_real_and_isr_kinematics
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_set_real_and_isr_kinematics &
(pcm_work, phs_identifiers, sqrts)
class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
real(default), intent(in) :: sqrts
end subroutine pcm_nlo_workspace_set_real_and_isr_kinematics
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_set_real_and_isr_kinematics &
(pcm_work, phs_identifiers, sqrts)
class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
real(default), intent(in) :: sqrts
call pcm_work%real_sub%set_real_kinematics &
(pcm_work%real_kinematics)
call pcm_work%real_sub%set_isr_kinematics &
(pcm_work%isr_kinematics)
end subroutine pcm_nlo_workspace_set_real_and_isr_kinematics
@ %def pcm_nlo_workspace_set_real_and_isr_kinematics
@
<<PCM: pcm instance: TBP>>=
procedure :: init_real_subtraction => pcm_nlo_workspace_init_real_subtraction
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_init_real_subtraction (pcm_work, pcm)
class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
class(pcm_t), intent(in) :: pcm
end subroutine pcm_nlo_workspace_init_real_subtraction
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_init_real_subtraction (pcm_work, pcm)
class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
class(pcm_t), intent(in) :: pcm
select type (pcm)
type is (pcm_nlo_t)
associate (region_data => pcm%region_data)
call pcm_work%real_sub%init (region_data, pcm%settings)
if (allocated (pcm%settings%selected_alr)) then
associate (selected_alr => pcm%settings%selected_alr)
if (any (selected_alr < 0)) then
call msg_fatal ("Fixed alpha region must be non-negative!")
else if (any (selected_alr > region_data%n_regions)) then
call msg_fatal ("Fixed alpha region is larger than the"&
&" total number of singular regions!")
else
allocate (pcm_work%real_sub%selected_alr &
(size (selected_alr)))
pcm_work%real_sub%selected_alr = selected_alr
end if
end associate
end if
end associate
end select
end subroutine pcm_nlo_workspace_init_real_subtraction
@ %def pcm_nlo_workspace_init_real_subtraction
@
<<PCM: pcm instance: TBP>>=
procedure :: set_momenta_and_scales_virtual => &
pcm_nlo_workspace_set_momenta_and_scales_virtual
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual &
(pcm_work, p, ren_scale, fac_scale, es_scale)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
type(vector4_t), intent(in), dimension(:) :: p
real(default), allocatable, intent(in) :: ren_scale
real(default), intent(in) :: fac_scale
real(default), allocatable, intent(in) :: es_scale
end subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual &
(pcm_work, p, ren_scale, fac_scale, es_scale)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
type(vector4_t), intent(in), dimension(:) :: p
real(default), allocatable, intent(in) :: ren_scale
real(default), intent(in) :: fac_scale
real(default), allocatable, intent(in) :: es_scale
associate (virtual => pcm_work%virtual)
call virtual%set_ren_scale (ren_scale)
call virtual%set_fac_scale (p, fac_scale)
call virtual%set_ellis_sexton_scale (es_scale)
end associate
end subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual
@ %def pcm_nlo_workspace_set_momenta_and_scales_virtual
@
<<PCM: pcm instance: TBP>>=
procedure :: set_fac_scale => pcm_nlo_workspace_set_fac_scale
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_set_fac_scale (pcm_work, fac_scale)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
real(default), intent(in) :: fac_scale
end subroutine pcm_nlo_workspace_set_fac_scale
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_set_fac_scale (pcm_work, fac_scale)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
real(default), intent(in) :: fac_scale
pcm_work%isr_kinematics%fac_scale = fac_scale
end subroutine pcm_nlo_workspace_set_fac_scale
@ %def pcm_nlo_workspace_set_fac_scale
@
<<PCM: pcm instance: TBP>>=
procedure :: set_momenta => pcm_nlo_workspace_set_momenta
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_set_momenta (pcm_work, &
p_born, p_real, i_phs, cms)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
type(vector4_t), dimension(:), intent(in) :: p_born, p_real
integer, intent(in) :: i_phs
logical, intent(in), optional :: cms
end subroutine pcm_nlo_workspace_set_momenta
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_set_momenta (pcm_work, &
p_born, p_real, i_phs, cms)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
type(vector4_t), dimension(:), intent(in) :: p_born, p_real
integer, intent(in) :: i_phs
logical, intent(in), optional :: cms
logical :: yorn
yorn = .false.; if (present (cms)) yorn = cms
associate (kinematics => pcm_work%real_kinematics)
if (yorn) then
if (.not. kinematics%p_born_cms%initialized) &
call kinematics%p_born_cms%init (size (p_born), 1)
if (.not. kinematics%p_real_cms%initialized) &
call kinematics%p_real_cms%init (size (p_real), 1)
kinematics%p_born_cms%phs_point(1) = p_born
kinematics%p_real_cms%phs_point(i_phs) = p_real
else
if (.not. kinematics%p_born_lab%initialized) &
call kinematics%p_born_lab%init (size (p_born), 1)
if (.not. kinematics%p_real_lab%initialized) &
call kinematics%p_real_lab%init (size (p_real), 1)
kinematics%p_born_lab%phs_point(1) = p_born
kinematics%p_real_lab%phs_point(i_phs) = p_real
end if
end associate
end subroutine pcm_nlo_workspace_set_momenta
@ %def pcm_nlo_workspace_set_momenta
@
<<PCM: pcm instance: TBP>>=
procedure :: get_momenta => pcm_nlo_workspace_get_momenta
<<PCM: sub interfaces>>=
module function pcm_nlo_workspace_get_momenta (pcm_work, pcm, &
i_phs, born_phsp, cms) result (p)
type(vector4_t), dimension(:), allocatable :: p
class(pcm_nlo_workspace_t), intent(in) :: pcm_work
class(pcm_t), intent(in) :: pcm
integer, intent(in) :: i_phs
logical, intent(in) :: born_phsp
logical, intent(in), optional :: cms
end function pcm_nlo_workspace_get_momenta
<<PCM: procedures>>=
module function pcm_nlo_workspace_get_momenta (pcm_work, pcm, &
i_phs, born_phsp, cms) result (p)
type(vector4_t), dimension(:), allocatable :: p
class(pcm_nlo_workspace_t), intent(in) :: pcm_work
class(pcm_t), intent(in) :: pcm
integer, intent(in) :: i_phs
logical, intent(in) :: born_phsp
logical, intent(in), optional :: cms
logical :: yorn
yorn = .false.; if (present (cms)) yorn = cms
select type (pcm)
type is (pcm_nlo_t)
if (born_phsp) then
if (yorn) then
p = pcm_work%real_kinematics%p_born_cms%phs_point(1)
else
p = pcm_work%real_kinematics%p_born_lab%phs_point(1)
end if
else
if (yorn) then
p = pcm_work%real_kinematics%p_real_cms%phs_point(i_phs)
else
p = pcm_work%real_kinematics%p_real_lab%phs_point(i_phs)
end if
end if
end select
end function pcm_nlo_workspace_get_momenta
@ %def pcm_nlo_workspace_get_momenta
@
<<PCM: pcm instance: TBP>>=
procedure :: get_xi_max => pcm_nlo_workspace_get_xi_max
<<PCM: sub interfaces>>=
module function pcm_nlo_workspace_get_xi_max (pcm_work, alr) result (xi_max)
real(default) :: xi_max
class(pcm_nlo_workspace_t), intent(in) :: pcm_work
integer, intent(in) :: alr
end function pcm_nlo_workspace_get_xi_max
<<PCM: procedures>>=
module function pcm_nlo_workspace_get_xi_max (pcm_work, alr) result (xi_max)
real(default) :: xi_max
class(pcm_nlo_workspace_t), intent(in) :: pcm_work
integer, intent(in) :: alr
integer :: i_phs
i_phs = pcm_work%real_kinematics%alr_to_i_phs (alr)
xi_max = pcm_work%real_kinematics%xi_max (i_phs)
end function pcm_nlo_workspace_get_xi_max
@ %def pcm_nlo_workspace_get_xi_max
@
<<PCM: pcm instance: TBP>>=
procedure :: set_x_rad => pcm_nlo_workspace_set_x_rad
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_set_x_rad (pcm_work, x_tot)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
real(default), intent(in), dimension(:) :: x_tot
end subroutine pcm_nlo_workspace_set_x_rad
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_set_x_rad (pcm_work, x_tot)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
real(default), intent(in), dimension(:) :: x_tot
integer :: n_par
n_par = size (x_tot)
if (n_par < 3) then
pcm_work%real_kinematics%x_rad = zero
else
pcm_work%real_kinematics%x_rad = x_tot (n_par - 2 : n_par)
end if
end subroutine pcm_nlo_workspace_set_x_rad
@ %def pcm_nlo_workspace_set_x_rad
@
<<PCM: pcm instance: TBP>>=
procedure :: init_virtual => pcm_nlo_workspace_init_virtual
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_init_virtual (pcm_work, pcm, model)
class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
class(pcm_t), intent(in) :: pcm
class(model_data_t), intent(in) :: model
end subroutine pcm_nlo_workspace_init_virtual
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_init_virtual (pcm_work, pcm, model)
class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
class(pcm_t), intent(in) :: pcm
class(model_data_t), intent(in) :: model
select type (pcm)
type is (pcm_nlo_t)
associate (region_data => pcm%region_data)
call pcm_work%virtual%init (region_data%get_flv_states_born (), &
region_data%n_in, pcm%settings, model, pcm%has_pdfs)
end associate
end select
end subroutine pcm_nlo_workspace_init_virtual
@ %def pcm_nlo_workspace_init_virtual
@
<<PCM: pcm instance: TBP>>=
procedure :: disable_virtual_subtraction => &
pcm_nlo_workspace_disable_virtual_subtraction
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_disable_virtual_subtraction (pcm_work)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
end subroutine pcm_nlo_workspace_disable_virtual_subtraction
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_disable_virtual_subtraction (pcm_work)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
end subroutine pcm_nlo_workspace_disable_virtual_subtraction
@ %def pcm_nlo_workspace_disable_virtual_subtraction
@
<<PCM: pcm instance: TBP>>=
procedure :: compute_sqme_virt => pcm_nlo_workspace_compute_sqme_virt
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_compute_sqme_virt (pcm_work, pcm, p, &
alpha_coupling, separate_uborns, sqme_virt)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
type(vector4_t), intent(in), dimension(:) :: p
real(default), dimension(2), intent(in) :: alpha_coupling
logical, intent(in) :: separate_uborns
real(default), dimension(:), allocatable, intent(inout) :: sqme_virt
end subroutine pcm_nlo_workspace_compute_sqme_virt
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_compute_sqme_virt (pcm_work, pcm, p, &
alpha_coupling, separate_uborns, sqme_virt)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
type(vector4_t), intent(in), dimension(:) :: p
real(default), dimension(2), intent(in) :: alpha_coupling
logical, intent(in) :: separate_uborns
real(default), dimension(:), allocatable, intent(inout) :: sqme_virt
type(vector4_t), dimension(:), allocatable :: pp
associate (virtual => pcm_work%virtual)
allocate (pp (size (p)))
if (virtual%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
pp = pcm_work%real_kinematics%p_born_onshell%get_momenta (1)
else
pp = p
end if
select type (pcm)
type is (pcm_nlo_t)
if (separate_uborns) then
allocate (sqme_virt (pcm%get_n_flv_born ()))
else
allocate (sqme_virt (1))
end if
sqme_virt = zero
call virtual%evaluate (pcm%region_data, &
alpha_coupling, pp, separate_uborns, sqme_virt)
end select
end associate
end subroutine pcm_nlo_workspace_compute_sqme_virt
@ %def pcm_nlo_workspace_compute_sqme_virt
@
<<PCM: pcm instance: TBP>>=
procedure :: compute_sqme_mismatch => pcm_nlo_workspace_compute_sqme_mismatch
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_compute_sqme_mismatch (pcm_work, pcm, &
alpha_s, separate_uborns, sqme_mism)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
real(default), intent(in) :: alpha_s
logical, intent(in) :: separate_uborns
real(default), dimension(:), allocatable, intent(inout) :: sqme_mism
end subroutine pcm_nlo_workspace_compute_sqme_mismatch
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_compute_sqme_mismatch (pcm_work, pcm, &
alpha_s, separate_uborns, sqme_mism)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
real(default), intent(in) :: alpha_s
logical, intent(in) :: separate_uborns
real(default), dimension(:), allocatable, intent(inout) :: sqme_mism
select type (pcm)
type is (pcm_nlo_t)
if (separate_uborns) then
allocate (sqme_mism (pcm%get_n_flv_born ()))
else
allocate (sqme_mism (1))
end if
sqme_mism = zero
sqme_mism = pcm_work%soft_mismatch%evaluate (alpha_s)
end select
end subroutine pcm_nlo_workspace_compute_sqme_mismatch
@ %def pcm_nlo_workspace_compute_sqme_mismatch
@
<<PCM: pcm instance: TBP>>=
procedure :: compute_sqme_dglap_remnant => &
pcm_nlo_workspace_compute_sqme_dglap_remnant
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant (pcm_work, &
pcm, alpha_coupling, separate_uborns, sqme_dglap)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
real(default), dimension(2), intent(in) :: alpha_coupling
logical, intent(in) :: separate_uborns
real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap
end subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant (pcm_work, &
pcm, alpha_coupling, separate_uborns, sqme_dglap)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
real(default), dimension(2), intent(in) :: alpha_coupling
logical, intent(in) :: separate_uborns
real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap
select type (pcm)
type is (pcm_nlo_t)
if (separate_uborns) then
allocate (sqme_dglap (pcm%get_n_flv_born ()))
else
allocate (sqme_dglap (1))
end if
end select
sqme_dglap = zero
call pcm_work%dglap_remnant%evaluate (alpha_coupling, &
separate_uborns, sqme_dglap)
end subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant
@ %def pcm_nlo_workspace_compute_sqme_dglap_remnant
@
<<PCM: pcm instance: TBP>>=
procedure :: set_fixed_order_event_mode => &
pcm_nlo_workspace_set_fixed_order_event_mode
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_set_fixed_order_event_mode (pcm_work)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
end subroutine pcm_nlo_workspace_set_fixed_order_event_mode
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_set_fixed_order_event_mode (pcm_work)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
pcm_work%real_sub%purpose = FIXED_ORDER_EVENTS
end subroutine pcm_nlo_workspace_set_fixed_order_event_mode
@ %def pcm_nlo_workspace_set_fixed_order_event_mode
@
<<PCM: pcm instance: TBP>>=
procedure :: init_soft_mismatch => pcm_nlo_workspace_init_soft_mismatch
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_init_soft_mismatch (pcm_work, pcm)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
end subroutine pcm_nlo_workspace_init_soft_mismatch
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_init_soft_mismatch (pcm_work, pcm)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
select type (pcm)
type is (pcm_nlo_t)
call pcm_work%soft_mismatch%init (pcm%region_data, &
pcm_work%real_kinematics, pcm%settings%factorization_mode)
end select
end subroutine pcm_nlo_workspace_init_soft_mismatch
@ %def pcm_nlo_workspace_init_soft_mismatch
@
<<PCM: pcm instance: TBP>>=
procedure :: init_dglap_remnant => pcm_nlo_workspace_init_dglap_remnant
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_init_dglap_remnant (pcm_work, pcm)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
end subroutine pcm_nlo_workspace_init_dglap_remnant
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_init_dglap_remnant (pcm_work, pcm)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
class(pcm_t), intent(in) :: pcm
select type (pcm)
type is (pcm_nlo_t)
call pcm_work%dglap_remnant%init ( &
pcm%settings, &
pcm%region_data, &
pcm_work%isr_kinematics)
end select
end subroutine pcm_nlo_workspace_init_dglap_remnant
@ %def pcm_nlo_workspace_init_dglap_remnant
@
<<PCM: pcm instance: TBP>>=
procedure :: is_fixed_order_nlo_events &
=> pcm_nlo_workspace_is_fixed_order_nlo_events
<<PCM: sub interfaces>>=
module function pcm_nlo_workspace_is_fixed_order_nlo_events &
(pcm_work) result (is_fnlo)
logical :: is_fnlo
class(pcm_nlo_workspace_t), intent(in) :: pcm_work
end function pcm_nlo_workspace_is_fixed_order_nlo_events
<<PCM: procedures>>=
module function pcm_nlo_workspace_is_fixed_order_nlo_events &
(pcm_work) result (is_fnlo)
logical :: is_fnlo
class(pcm_nlo_workspace_t), intent(in) :: pcm_work
is_fnlo = pcm_work%real_sub%purpose == FIXED_ORDER_EVENTS
end function pcm_nlo_workspace_is_fixed_order_nlo_events
@ %def pcm_nlo_workspace_is_fixed_order_nlo_events
@
<<PCM: pcm instance: TBP>>=
procedure :: final => pcm_nlo_workspace_final
<<PCM: sub interfaces>>=
module subroutine pcm_nlo_workspace_final (pcm_work)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
end subroutine pcm_nlo_workspace_final
<<PCM: procedures>>=
module subroutine pcm_nlo_workspace_final (pcm_work)
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
call pcm_work%real_sub%final ()
call pcm_work%virtual%final ()
call pcm_work%soft_mismatch%final ()
call pcm_work%dglap_remnant%final ()
if (associated (pcm_work%real_kinematics)) then
call pcm_work%real_kinematics%final ()
nullify (pcm_work%real_kinematics)
end if
if (associated (pcm_work%isr_kinematics)) then
nullify (pcm_work%isr_kinematics)
end if
end subroutine pcm_nlo_workspace_final
@ %def pcm_nlo_workspace_final
@
<<PCM: pcm instance: TBP>>=
procedure :: is_nlo => pcm_nlo_workspace_is_nlo
<<PCM: sub interfaces>>=
module function pcm_nlo_workspace_is_nlo (pcm_work) result (is_nlo)
logical :: is_nlo
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
end function pcm_nlo_workspace_is_nlo
<<PCM: procedures>>=
module function pcm_nlo_workspace_is_nlo (pcm_work) result (is_nlo)
logical :: is_nlo
class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
is_nlo = .true.
end function pcm_nlo_workspace_is_nlo
@ %def pcm_nlo_workspace_is_nlo
@ This routine modifies the kinematic factors applied to the real matrix element
for use with POWHEG matching. We need to divide the real matrix element by [[xi_max]] to
cancel a factor of [[xi_max]] applied in [[apply_kinematic_factors_radiation]].
It comes from the fact that we sample $\tilde\xi \in [0,1]$ when integrating
but $\xi \in [p_T^2,\xi_\text{max}]$ for POWHEG matching.
Thus, we are taking into account that $d\xi = d\tilde\xi
\frac{\xi}{\tilde\xi} = d\tilde\xi \xi_\text{max}$.
Additionally, we need to cancel the Jacobian from the random number mapping.
We only want the physical part of the Jacobian in our Sudakov splitting function.
Furthermore, the real matrix element lacks its flux factor
$\frac{1}{2 \hat s_{\mathcal{R}}}$ and the real Jacobian lacks a factor of
$\frac{1}{1-\xi}$. Together, this is a factor of $\frac{1}{2 \hat s_{\mathcal{B}}}$,
i.e. the same as the flux factor of the Born matrix element. We do not correct
any of both here, as only the ratio of both will be relevant for the Sudakov.
<<PCM: pcm instance: TBP>>=
procedure :: powheg_kinematic_factors_real => &
pcm_nlo_workspace_powheg_kinematic_factors_real
<<PCM: sub interfaces>>=
module function pcm_nlo_workspace_powheg_kinematic_factors_real &
(pcm_work, sqme_real, alr) result (sqme_real_corr)
real(default) :: sqme_real_corr
class(pcm_nlo_workspace_t), intent(in) :: pcm_work
real(default), intent(in) :: sqme_real
integer, intent(in) :: alr
end function pcm_nlo_workspace_powheg_kinematic_factors_real
<<PCM: procedures>>=
module function pcm_nlo_workspace_powheg_kinematic_factors_real &
(pcm_work, sqme_real, alr) result (sqme_real_corr)
real(default) :: sqme_real_corr
class(pcm_nlo_workspace_t), intent(in) :: pcm_work
real(default), intent(in) :: sqme_real
integer, intent(in) :: alr
real(default) :: xi_max, jac_rand
integer :: i_phs
xi_max = pcm_work%get_xi_max (alr)
i_phs = pcm_work%real_kinematics%alr_to_i_phs (alr)
jac_rand = pcm_work%real_kinematics%jac_rand (i_phs)
sqme_real_corr = sqme_real / xi_max / jac_rand
end function pcm_nlo_workspace_powheg_kinematic_factors_real
@ %def pcm_nlo_workspace_powheg_kinematic_factors_real
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Kinematics instance}
In this data type we combine all objects (instances) necessary for
generating (or recovering) a kinematical configuration. The
components work together as an implementation of multi-channel phase
space.
[[sf_chain]] is an instance of the structure-function chain. It is
used both for generating kinematics and, after the proper scale has
been determined, evaluating the structure function entries.
[[phs]] is an instance of the phase space for the elementary process.
The array [[f]] contains the products of the Jacobians that originate
from parameter mappings in the structure-function chain or in the
phase space. We allocate this explicitly if either [[sf_chain]] or
[[phs]] are explicitly allocated, otherwise we can take over a pointer.
All components are implemented as pointers to (anonymous) targets.
For each component, there is a flag that tells whether this component
is to be regarded as a proper component (`owned' by the object) or as
a pointer.
@
<<[[kinematics.f90]]>>=
<<File header>>
module kinematics
<<Use kinds>>
use lorentz
use physics_defs
use sf_base
use phs_base
use fks_regions
use mci_base
use process_config
use process_mci
use pcm_base, only: pcm_t, pcm_workspace_t
use pcm, only: pcm_nlo_t, pcm_nlo_workspace_t
<<Standard module head>>
<<Kinematics: public>>
<<Kinematics: types>>
interface
<<Kinematics: sub interfaces>>
end interface
end module kinematics
@ %def kinematics
@
<<[[kinematics_sub.f90]]>>=
<<File header>>
submodule (kinematics) kinematics_s
<<Use debug>>
use format_utils, only: write_separator
use diagnostics
use io_units
use phs_points, only: assignment(=), size
use interactions
use phs_fks
use ttv_formfactors, only: m1s_to_mpole
implicit none
contains
<<Kinematics: procedures>>
end submodule kinematics_s
@ %def kinematics_s
@
<<Kinematics: public>>=
public :: kinematics_t
<<Kinematics: types>>=
type :: kinematics_t
integer :: n_in = 0
integer :: n_channel = 0
integer :: selected_channel = 0
type(sf_chain_instance_t), pointer :: sf_chain => null ()
class(phs_t), pointer :: phs => null ()
real(default), dimension(:), pointer :: f => null ()
real(default) :: phs_factor
logical :: sf_chain_allocated = .false.
logical :: phs_allocated = .false.
logical :: f_allocated = .false.
integer :: emitter = -1
integer :: i_phs = 0
integer :: i_con = 0
logical :: only_cm_frame = .false.
logical :: new_seed = .true.
logical :: threshold = .false.
contains
<<Kinematics: kinematics: TBP>>
end type kinematics_t
@ %def kinematics_t
@ Output. Show only those components which are marked as owned.
<<Kinematics: kinematics: TBP>>=
procedure :: write => kinematics_write
<<Kinematics: sub interfaces>>=
module subroutine kinematics_write (object, unit)
class(kinematics_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine kinematics_write
<<Kinematics: procedures>>=
module subroutine kinematics_write (object, unit)
class(kinematics_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, c
u = given_output_unit (unit)
if (object%f_allocated) then
write (u, "(1x,A)") "Flux * PHS volume:"
write (u, "(2x,ES19.12)") object%phs_factor
write (u, "(1x,A)") "Jacobian factors per channel:"
do c = 1, size (object%f)
write (u, "(3x,I0,':',1x,ES14.7)", advance="no") c, object%f(c)
if (c == object%selected_channel) then
write (u, "(1x,A)") "[selected]"
else
write (u, *)
end if
end do
end if
if (object%sf_chain_allocated) then
call write_separator (u)
call object%sf_chain%write (u)
end if
if (object%phs_allocated) then
call write_separator (u)
call object%phs%write (u)
end if
end subroutine kinematics_write
@ %def kinematics_write
@ Finalizer. Delete only those components which are marked as owned.
<<Kinematics: kinematics: TBP>>=
procedure :: final => kinematics_final
<<Kinematics: sub interfaces>>=
module subroutine kinematics_final (object)
class(kinematics_t), intent(inout) :: object
end subroutine kinematics_final
<<Kinematics: procedures>>=
module subroutine kinematics_final (object)
class(kinematics_t), intent(inout) :: object
if (object%sf_chain_allocated) then
call object%sf_chain%final ()
deallocate (object%sf_chain)
object%sf_chain_allocated = .false.
end if
if (object%phs_allocated) then
call object%phs%final ()
deallocate (object%phs)
object%phs_allocated = .false.
end if
if (object%f_allocated) then
deallocate (object%f)
object%f_allocated = .false.
end if
end subroutine kinematics_final
@ %def kinematics_final
@ Configure the kinematics object. This consists of several
configuration steps which correspond to individual procedures. In
essence, we configure the structure-function part, the partonic
phase-space part, and various NLO items.
TODO wk 19-03-01: This includes some region-data setup within [[pcm]],
hence [[pcm]] is intent(inout). This should be moved elsewhere, so
[[pcm]] can become strictly intent(in).
<<Kinematics: kinematics: TBP>>=
procedure :: configure => kinematics_configure
<<Kinematics: sub interfaces>>=
module subroutine kinematics_configure (kin, pcm, pcm_work, &
sf_chain, beam_config, phs_config, nlo_type, is_i_sub)
class(kinematics_t), intent(out) :: kin
class(pcm_t), intent(inout) :: pcm
class(pcm_workspace_t), intent(in) :: pcm_work
type(sf_chain_t), intent(in), target :: sf_chain
type(process_beam_config_t), intent(in), target :: beam_config
class(phs_config_t), intent(in), target :: phs_config
integer, intent(in) :: nlo_type
logical, intent(in) :: is_i_sub
end subroutine kinematics_configure
<<Kinematics: procedures>>=
module subroutine kinematics_configure (kin, pcm, pcm_work, &
sf_chain, beam_config, phs_config, nlo_type, is_i_sub)
class(kinematics_t), intent(out) :: kin
class(pcm_t), intent(inout) :: pcm
class(pcm_workspace_t), intent(in) :: pcm_work
type(sf_chain_t), intent(in), target :: sf_chain
type(process_beam_config_t), intent(in), target :: beam_config
class(phs_config_t), intent(in), target :: phs_config
integer, intent(in) :: nlo_type
logical, intent(in) :: is_i_sub
logical :: extended_sf
extended_sf = nlo_type == NLO_DGLAP .or. &
(nlo_type == NLO_REAL .and. is_i_sub)
call kin%init_sf_chain (sf_chain, beam_config, &
extended_sf = pcm%has_pdfs .and. extended_sf)
!!! Add one for additional Born matrix element
call kin%init_phs (phs_config)
call kin%set_nlo_info (nlo_type)
select type (phs => kin%phs)
type is (phs_fks_t)
call phs%allocate_momenta (phs_config, .not. (nlo_type == NLO_REAL))
select type (pcm)
type is (pcm_nlo_t)
call pcm%region_data%init_phs_identifiers (phs%phs_identifiers)
!!! The triple select type pyramid of doom
select type (pcm_work)
type is (pcm_nlo_workspace_t)
if (allocated (pcm_work%real_kinematics%alr_to_i_phs)) &
call pcm%region_data%set_alr_to_i_phs (phs%phs_identifiers, &
pcm_work%real_kinematics%alr_to_i_phs)
end select
end select
end select
end subroutine kinematics_configure
@ %def kinematics_configure
@ Set the flags indicating whether the phase space shall be set up for the calculation of the real contribution. For this case, also set the emitter.
<<Kinematics: kinematics: TBP>>=
procedure :: set_nlo_info => kinematics_set_nlo_info
<<Kinematics: sub interfaces>>=
module subroutine kinematics_set_nlo_info (k, nlo_type)
class(kinematics_t), intent(inout) :: k
integer, intent(in) :: nlo_type
end subroutine kinematics_set_nlo_info
<<Kinematics: procedures>>=
module subroutine kinematics_set_nlo_info (k, nlo_type)
class(kinematics_t), intent(inout) :: k
integer, intent(in) :: nlo_type
if (nlo_type == NLO_VIRTUAL) k%only_cm_frame = .true.
end subroutine kinematics_set_nlo_info
@ %def kinematics_set_nlo_info
@
<<Kinematics: kinematics: TBP>>=
procedure :: set_threshold => kinematics_set_threshold
<<Kinematics: sub interfaces>>=
module subroutine kinematics_set_threshold (kin, factorization_mode)
class(kinematics_t), intent(inout) :: kin
integer, intent(in) :: factorization_mode
end subroutine kinematics_set_threshold
<<Kinematics: procedures>>=
module subroutine kinematics_set_threshold (kin, factorization_mode)
class(kinematics_t), intent(inout) :: kin
integer, intent(in) :: factorization_mode
kin%threshold = factorization_mode == FACTORIZATION_THRESHOLD
end subroutine kinematics_set_threshold
@ %def kinematics_set_threshold
@ Allocate the structure-function chain instance, initialize it as a
copy of the [[sf_chain]] template, and prepare it for evaluation.
The [[sf_chain]] remains a target because the (usually constant) beam momenta
are taken from there.
<<Kinematics: kinematics: TBP>>=
procedure :: init_sf_chain => kinematics_init_sf_chain
<<Kinematics: sub interfaces>>=
module subroutine kinematics_init_sf_chain &
(k, sf_chain, config, extended_sf)
class(kinematics_t), intent(inout) :: k
type(sf_chain_t), intent(in), target :: sf_chain
type(process_beam_config_t), intent(in) :: config
logical, intent(in), optional :: extended_sf
end subroutine kinematics_init_sf_chain
<<Kinematics: procedures>>=
module subroutine kinematics_init_sf_chain (k, sf_chain, config, extended_sf)
class(kinematics_t), intent(inout) :: k
type(sf_chain_t), intent(in), target :: sf_chain
type(process_beam_config_t), intent(in) :: config
logical, intent(in), optional :: extended_sf
integer :: n_strfun, n_channel
integer :: c
k%n_in = config%data%get_n_in ()
n_strfun = config%n_strfun
n_channel = config%n_channel
allocate (k%sf_chain)
k%sf_chain_allocated = .true.
call k%sf_chain%init (sf_chain, n_channel)
if (n_strfun /= 0) then
do c = 1, n_channel
call k%sf_chain%set_channel (c, config%sf_channel(c))
end do
end if
call k%sf_chain%link_interactions ()
call k%sf_chain%exchange_mask ()
call k%sf_chain%init_evaluators (extended_sf = extended_sf)
end subroutine kinematics_init_sf_chain
@ %def kinematics_init_sf_chain
@ Allocate and initialize the phase-space part and the array of
Jacobian factors.
<<Kinematics: kinematics: TBP>>=
procedure :: init_phs => kinematics_init_phs
<<Kinematics: sub interfaces>>=
module subroutine kinematics_init_phs (k, config)
class(kinematics_t), intent(inout) :: k
class(phs_config_t), intent(in), target :: config
end subroutine kinematics_init_phs
<<Kinematics: procedures>>=
module subroutine kinematics_init_phs (k, config)
class(kinematics_t), intent(inout) :: k
class(phs_config_t), intent(in), target :: config
k%n_channel = config%get_n_channel ()
call config%allocate_instance (k%phs)
call k%phs%init (config)
k%phs_allocated = .true.
allocate (k%f (k%n_channel))
k%f = 0
k%f_allocated = .true.
end subroutine kinematics_init_phs
@ %def kinematics_init_phs
@
<<Kinematics: kinematics: TBP>>=
procedure :: evaluate_radiation_kinematics => &
kinematics_evaluate_radiation_kinematics
<<Kinematics: sub interfaces>>=
module subroutine kinematics_evaluate_radiation_kinematics (k, r_in)
class(kinematics_t), intent(inout) :: k
real(default), intent(in), dimension(:) :: r_in
end subroutine kinematics_evaluate_radiation_kinematics
<<Kinematics: procedures>>=
module subroutine kinematics_evaluate_radiation_kinematics (k, r_in)
class(kinematics_t), intent(inout) :: k
real(default), intent(in), dimension(:) :: r_in
select type (phs => k%phs)
type is (phs_fks_t)
if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) then
call phs%generate_radiation_variables &
(r_in(phs%n_r_born + 1 : phs%n_r_born + 3), &
threshold = k%threshold)
call phs%compute_cms_energy ()
end if
end select
end subroutine kinematics_evaluate_radiation_kinematics
@ %def kinematics_evaluate_radiation_kinematics
@
<<Kinematics: kinematics: TBP>>=
procedure :: generate_fsr_in => kinematics_generate_fsr_in
<<Kinematics: sub interfaces>>=
module subroutine kinematics_generate_fsr_in (kin)
class(kinematics_t), intent(inout) :: kin
end subroutine kinematics_generate_fsr_in
<<Kinematics: procedures>>=
module subroutine kinematics_generate_fsr_in (kin)
class(kinematics_t), intent(inout) :: kin
select type (phs => kin%phs)
type is (phs_fks_t)
call phs%generate_fsr_in ()
end select
end subroutine kinematics_generate_fsr_in
@ %def kinematics_generate_fsr_in
@
<<Kinematics: kinematics: TBP>>=
procedure :: compute_xi_ref_momenta => kinematics_compute_xi_ref_momenta
<<Kinematics: sub interfaces>>=
module subroutine kinematics_compute_xi_ref_momenta (k, reg_data, nlo_type)
class(kinematics_t), intent(inout) :: k
type(region_data_t), intent(in) :: reg_data
integer, intent(in) :: nlo_type
end subroutine kinematics_compute_xi_ref_momenta
<<Kinematics: procedures>>=
module subroutine kinematics_compute_xi_ref_momenta (k, reg_data, nlo_type)
class(kinematics_t), intent(inout) :: k
type(region_data_t), intent(in) :: reg_data
integer, intent(in) :: nlo_type
logical :: use_contributors
use_contributors = allocated (reg_data%alr_contributors)
select type (phs => k%phs)
type is (phs_fks_t)
if (use_contributors) then
call phs%compute_xi_ref_momenta (contributors = reg_data%alr_contributors)
else if (k%threshold) then
if (.not. is_subtraction_component (k%emitter, nlo_type)) &
call phs%compute_xi_ref_momenta_threshold ()
else
call phs%compute_xi_ref_momenta ()
end if
end select
end subroutine kinematics_compute_xi_ref_momenta
@ %def kinematics_compute_xi_ref_momenta
@ Generate kinematics, given a phase-space channel and a MC
parameter set. The main result is the momentum array [[p]], but we
also fill the momentum entries in the structure-function chain and the
Jacobian-factor array [[f]]. Regarding phase space, we fill only the
parameter arrays for the selected channel.
<<Kinematics: kinematics: TBP>>=
procedure :: compute_selected_channel => kinematics_compute_selected_channel
<<Kinematics: sub interfaces>>=
module subroutine kinematics_compute_selected_channel &
(k, mci_work, phs_channel, p, success)
class(kinematics_t), intent(inout) :: k
type(mci_work_t), intent(in) :: mci_work
integer, intent(in) :: phs_channel
type(vector4_t), dimension(:), intent(out) :: p
logical, intent(out) :: success
end subroutine kinematics_compute_selected_channel
<<Kinematics: procedures>>=
module subroutine kinematics_compute_selected_channel &
(k, mci_work, phs_channel, p, success)
class(kinematics_t), intent(inout) :: k
type(mci_work_t), intent(in) :: mci_work
integer, intent(in) :: phs_channel
type(vector4_t), dimension(:), intent(out) :: p
logical, intent(out) :: success
integer :: sf_channel
k%selected_channel = phs_channel
sf_channel = k%phs%config%get_sf_channel (phs_channel)
call k%sf_chain%compute_kinematics (sf_channel, mci_work%get_x_strfun ())
call k%sf_chain%get_out_momenta (p(1:k%n_in))
call k%phs%set_incoming_momenta (p(1:k%n_in))
call k%phs%compute_flux ()
call k%phs%select_channel (phs_channel)
call k%phs%evaluate_selected_channel (phs_channel, &
mci_work%get_x_process ())
select type (phs => k%phs)
type is (phs_fks_t)
if (debug_on) call msg_debug2 (D_REAL, "phase space is phs_FKS")
if (phs%q_defined) then
call phs%get_born_momenta (p)
if (debug_on) then
call msg_debug2 (D_REAL, "q is defined")
call msg_debug2 (D_REAL, "get_born_momenta called")
end if
k%phs_factor = phs%get_overall_factor ()
success = .true.
else
k%phs_factor = 0
success = .false.
end if
class default
if (phs%q_defined) then
call k%phs%get_outgoing_momenta (p(k%n_in + 1 :))
k%phs_factor = k%phs%get_overall_factor ()
success = .true.
else
k%phs_factor = 0
success = .false.
end if
end select
end subroutine kinematics_compute_selected_channel
@ %def kinematics_compute_selected_channel
@
<<Kinematics: kinematics: TBP>>=
procedure :: redo_sf_chain => kinematics_redo_sf_chain
<<Kinematics: sub interfaces>>=
module subroutine kinematics_redo_sf_chain (kin, mci_work, phs_channel)
class(kinematics_t), intent(inout) :: kin
type(mci_work_t), intent(in) :: mci_work
integer, intent(in) :: phs_channel
end subroutine kinematics_redo_sf_chain
<<Kinematics: procedures>>=
module subroutine kinematics_redo_sf_chain (kin, mci_work, phs_channel)
class(kinematics_t), intent(inout) :: kin
type(mci_work_t), intent(in) :: mci_work
integer, intent(in) :: phs_channel
real(default), dimension(:), allocatable :: x
integer :: sf_channel, n
real(default) :: xi, y
n = size (mci_work%get_x_strfun ())
if (n > 0) then
allocate (x(n))
x = mci_work%get_x_strfun ()
sf_channel = kin%phs%config%get_sf_channel (phs_channel)
call kin%sf_chain%compute_kinematics (sf_channel, x)
end if
end subroutine kinematics_redo_sf_chain
@ %def kinematics_redo_sf_chain
@ Complete kinematics by filling the non-selected phase-space parameter
arrays.
<<Kinematics: kinematics: TBP>>=
procedure :: compute_other_channels => kinematics_compute_other_channels
<<Kinematics: sub interfaces>>=
module subroutine kinematics_compute_other_channels &
(k, mci_work, phs_channel)
class(kinematics_t), intent(inout) :: k
type(mci_work_t), intent(in) :: mci_work
integer, intent(in) :: phs_channel
end subroutine kinematics_compute_other_channels
<<Kinematics: procedures>>=
module subroutine kinematics_compute_other_channels (k, mci_work, phs_channel)
class(kinematics_t), intent(inout) :: k
type(mci_work_t), intent(in) :: mci_work
integer, intent(in) :: phs_channel
integer :: c, c_sf
call k%phs%evaluate_other_channels (phs_channel)
do c = 1, k%n_channel
c_sf = k%phs%config%get_sf_channel (c)
k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c)
end do
end subroutine kinematics_compute_other_channels
@ %def kinematics_compute_other_channels
@ Just fetch the outgoing momenta of the [[sf_chain]] subobject, which
become the incoming (seed) momenta of the hard interaction.
This is a stripped down-version of the above which we use when
recovering kinematics. Momenta are known, but no MC parameters yet.
(We do not use the [[get_out_momenta]] method of the chain, since this
relies on the structure-function interactions, which are not necessary
filled here. We do rely on the momenta of the last evaluator in the
chain, however.)
<<Kinematics: kinematics: TBP>>=
procedure :: get_incoming_momenta => kinematics_get_incoming_momenta
<<Kinematics: sub interfaces>>=
module subroutine kinematics_get_incoming_momenta (k, p)
class(kinematics_t), intent(in) :: k
type(vector4_t), dimension(:), intent(out) :: p
end subroutine kinematics_get_incoming_momenta
<<Kinematics: procedures>>=
module subroutine kinematics_get_incoming_momenta (k, p)
class(kinematics_t), intent(in) :: k
type(vector4_t), dimension(:), intent(out) :: p
type(interaction_t), pointer :: int
integer :: i
int => k%sf_chain%get_out_int_ptr ()
do i = 1, k%n_in
p(i) = int%get_momentum (k%sf_chain%get_out_i (i))
end do
end subroutine kinematics_get_incoming_momenta
@ %def kinematics_get_incoming_momenta
@
<<Kinematics: kinematics: TBP>>=
procedure :: get_boost_to_lab => kinematics_get_boost_to_lab
<<Kinematics: sub interfaces>>=
module function kinematics_get_boost_to_lab (kin) result (lt)
type(lorentz_transformation_t) :: lt
class(kinematics_t), intent(in) :: kin
end function kinematics_get_boost_to_lab
<<Kinematics: procedures>>=
module function kinematics_get_boost_to_lab (kin) result (lt)
type(lorentz_transformation_t) :: lt
class(kinematics_t), intent(in) :: kin
lt = kin%phs%get_lorentz_transformation ()
end function kinematics_get_boost_to_lab
@ %def kinematics_get_boost_to_lab
@
<<Kinematics: kinematics: TBP>>=
procedure :: get_boost_to_cms => kinematics_get_boost_to_cms
<<Kinematics: sub interfaces>>=
module function kinematics_get_boost_to_cms (kin) result (lt)
type(lorentz_transformation_t) :: lt
class(kinematics_t), intent(in) :: kin
end function kinematics_get_boost_to_cms
<<Kinematics: procedures>>=
module function kinematics_get_boost_to_cms (kin) result (lt)
type(lorentz_transformation_t) :: lt
class(kinematics_t), intent(in) :: kin
lt = inverse (kin%phs%get_lorentz_transformation ())
end function kinematics_get_boost_to_cms
@ %def kinematics_get_boost_to_cms
@ This inverts the remainder of the above [[compute]] method. We know
the momenta and recover the rest, as far as needed. If we select a
channel, we can complete the inversion and reconstruct the
MC parameter set.
<<Kinematics: kinematics: TBP>>=
procedure :: recover_mcpar => kinematics_recover_mcpar
<<Kinematics: sub interfaces>>=
module subroutine kinematics_recover_mcpar (k, mci_work, phs_channel, p)
class(kinematics_t), intent(inout) :: k
type(mci_work_t), intent(inout) :: mci_work
integer, intent(in) :: phs_channel
type(vector4_t), dimension(:), intent(in) :: p
end subroutine kinematics_recover_mcpar
<<Kinematics: procedures>>=
module subroutine kinematics_recover_mcpar (k, mci_work, phs_channel, p)
class(kinematics_t), intent(inout) :: k
type(mci_work_t), intent(inout) :: mci_work
integer, intent(in) :: phs_channel
type(vector4_t), dimension(:), intent(in) :: p
integer :: c, c_sf
real(default), dimension(:), allocatable :: x_sf, x_phs
c = phs_channel
c_sf = k%phs%config%get_sf_channel (c)
k%selected_channel = c
call k%sf_chain%recover_kinematics (c_sf)
call k%phs%set_incoming_momenta (p(1:k%n_in))
call k%phs%compute_flux ()
call k%phs%set_outgoing_momenta (p(k%n_in+1:))
call k%phs%inverse ()
do c = 1, k%n_channel
c_sf = k%phs%config%get_sf_channel (c)
k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c)
end do
k%phs_factor = k%phs%get_overall_factor ()
c = phs_channel
c_sf = k%phs%config%get_sf_channel (c)
allocate (x_sf (k%sf_chain%config%get_n_bound ()))
allocate (x_phs (k%phs%config%get_n_par ()))
call k%phs%select_channel (c)
call k%sf_chain%get_mcpar (c_sf, x_sf)
call k%phs%get_mcpar (c, x_phs)
call mci_work%set_x_strfun (x_sf)
call mci_work%set_x_process (x_phs)
end subroutine kinematics_recover_mcpar
@ %def kinematics_recover_mcpar
@ This first part of [[recover_mcpar]]: just handle the sfchain.
<<Kinematics: kinematics: TBP>>=
procedure :: recover_sfchain => kinematics_recover_sfchain
<<Kinematics: sub interfaces>>=
module subroutine kinematics_recover_sfchain (k, channel, p)
class(kinematics_t), intent(inout) :: k
integer, intent(in) :: channel
type(vector4_t), dimension(:), intent(in) :: p
end subroutine kinematics_recover_sfchain
<<Kinematics: procedures>>=
module subroutine kinematics_recover_sfchain (k, channel, p)
class(kinematics_t), intent(inout) :: k
integer, intent(in) :: channel
type(vector4_t), dimension(:), intent(in) :: p
k%selected_channel = channel
call k%sf_chain%recover_kinematics (channel)
end subroutine kinematics_recover_sfchain
@ %def kinematics_recover_sfchain
@ Retrieve the MC input parameter array for a specific channel. We assume
that the kinematics is complete, so this is known for all channels.
<<Kinematics: kinematics: TBP>>=
procedure :: get_mcpar => kinematics_get_mcpar
<<Kinematics: sub interfaces>>=
module subroutine kinematics_get_mcpar (k, phs_channel, r)
class(kinematics_t), intent(in) :: k
integer, intent(in) :: phs_channel
real(default), dimension(:), intent(out) :: r
end subroutine kinematics_get_mcpar
<<Kinematics: procedures>>=
module subroutine kinematics_get_mcpar (k, phs_channel, r)
class(kinematics_t), intent(in) :: k
integer, intent(in) :: phs_channel
real(default), dimension(:), intent(out) :: r
integer :: sf_channel, n_par_sf, n_par_phs
sf_channel = k%phs%config%get_sf_channel (phs_channel)
n_par_phs = k%phs%config%get_n_par ()
n_par_sf = k%sf_chain%config%get_n_bound ()
if (n_par_sf > 0) then
call k%sf_chain%get_mcpar (sf_channel, r(1:n_par_sf))
end if
if (n_par_phs > 0) then
call k%phs%get_mcpar (phs_channel, r(n_par_sf+1:))
end if
end subroutine kinematics_get_mcpar
@ %def kinematics_get_mcpar
@ Evaluate the structure function chain, assuming that kinematics is known.
The status must be precisely [[SF_DONE_KINEMATICS]]. We thus avoid
evaluating the chain twice via different pointers to the same target.
<<Kinematics: kinematics: TBP>>=
procedure :: evaluate_sf_chain => kinematics_evaluate_sf_chain
<<Kinematics: sub interfaces>>=
module subroutine kinematics_evaluate_sf_chain &
(k, fac_scale, negative_sf, sf_rescale)
class(kinematics_t), intent(inout) :: k
real(default), intent(in) :: fac_scale
logical, intent(in), optional :: negative_sf
class(sf_rescale_t), intent(inout), optional :: sf_rescale
end subroutine kinematics_evaluate_sf_chain
<<Kinematics: procedures>>=
module subroutine kinematics_evaluate_sf_chain &
(k, fac_scale, negative_sf, sf_rescale)
class(kinematics_t), intent(inout) :: k
real(default), intent(in) :: fac_scale
logical, intent(in), optional :: negative_sf
class(sf_rescale_t), intent(inout), optional :: sf_rescale
select case (k%sf_chain%get_status ())
case (SF_DONE_KINEMATICS)
call k%sf_chain%evaluate (fac_scale, negative_sf = negative_sf, &
sf_rescale = sf_rescale)
end select
end subroutine kinematics_evaluate_sf_chain
@ %def kinematics_evaluate_sf_chain
@ Recover beam momenta, i.e., return the beam momenta stored in the
current [[sf_chain]] to their source. This is a side effect.
<<Kinematics: kinematics: TBP>>=
procedure :: return_beam_momenta => kinematics_return_beam_momenta
<<Kinematics: sub interfaces>>=
module subroutine kinematics_return_beam_momenta (k)
class(kinematics_t), intent(in) :: k
end subroutine kinematics_return_beam_momenta
<<Kinematics: procedures>>=
module subroutine kinematics_return_beam_momenta (k)
class(kinematics_t), intent(in) :: k
call k%sf_chain%return_beam_momenta ()
end subroutine kinematics_return_beam_momenta
@ %def kinematics_return_beam_momenta
@ Check wether the phase space is configured in the center-of-mass frame.
Relevant for using the proper momenta input for BLHA matrix elements.
<<Kinematics: kinematics: TBP>>=
procedure :: lab_is_cm => kinematics_lab_is_cm
<<Kinematics: sub interfaces>>=
module function kinematics_lab_is_cm (k) result (lab_is_cm)
logical :: lab_is_cm
class(kinematics_t), intent(in) :: k
end function kinematics_lab_is_cm
<<Kinematics: procedures>>=
module function kinematics_lab_is_cm (k) result (lab_is_cm)
logical :: lab_is_cm
class(kinematics_t), intent(in) :: k
lab_is_cm = k%phs%config%lab_is_cm
end function kinematics_lab_is_cm
@ %def kinematics_lab_is_cm
@
<<Kinematics: kinematics: TBP>>=
procedure :: modify_momenta_for_subtraction => &
kinematics_modify_momenta_for_subtraction
<<Kinematics: sub interfaces>>=
module subroutine kinematics_modify_momenta_for_subtraction (k, p_in, p_out)
class(kinematics_t), intent(inout) :: k
type(vector4_t), intent(in), dimension(:) :: p_in
type(vector4_t), intent(out), dimension(:), allocatable :: p_out
end subroutine kinematics_modify_momenta_for_subtraction
<<Kinematics: procedures>>=
module subroutine kinematics_modify_momenta_for_subtraction (k, p_in, p_out)
class(kinematics_t), intent(inout) :: k
type(vector4_t), intent(in), dimension(:) :: p_in
type(vector4_t), intent(out), dimension(:), allocatable :: p_out
allocate (p_out (size (p_in)))
if (k%threshold) then
select type (phs => k%phs)
type is (phs_fks_t)
p_out = phs%get_onshell_projected_momenta ()
end select
else
p_out = p_in
end if
end subroutine kinematics_modify_momenta_for_subtraction
@ %def kinematics_modify_momenta_for_subtraction
@
<<Kinematics: kinematics: TBP>>=
procedure :: threshold_projection => kinematics_threshold_projection
<<Kinematics: sub interfaces>>=
module subroutine kinematics_threshold_projection (k, pcm_work, nlo_type)
class(kinematics_t), intent(inout) :: k
type(pcm_nlo_workspace_t), intent(inout) :: pcm_work
integer, intent(in) :: nlo_type
end subroutine kinematics_threshold_projection
<<Kinematics: procedures>>=
module subroutine kinematics_threshold_projection (k, pcm_work, nlo_type)
class(kinematics_t), intent(inout) :: k
type(pcm_nlo_workspace_t), intent(inout) :: pcm_work
integer, intent(in) :: nlo_type
real(default) :: sqrts, mtop
type(lorentz_transformation_t) :: L_to_cms
type(vector4_t), dimension(:), allocatable :: p_tot, p_onshell
integer :: n_tot
n_tot = k%phs%get_n_tot ()
allocate (p_tot (size (pcm_work%real_kinematics%p_born_cms%phs_point(1))))
select type (phs => k%phs)
type is (phs_fks_t)
p_tot = pcm_work%real_kinematics%p_born_cms%phs_point(1)
class default
p_tot(1 : k%n_in) = phs%p
p_tot(k%n_in + 1 : n_tot) = phs%q
end select
sqrts = sum (p_tot (1:k%n_in))**1
mtop = m1s_to_mpole (sqrts)
L_to_cms = get_boost_for_threshold_projection (p_tot, sqrts, mtop)
call pcm_work%real_kinematics%p_born_cms%set_momenta (1, p_tot)
p_onshell = pcm_work%real_kinematics%p_born_onshell%phs_point(1)
call threshold_projection_born (mtop, L_to_cms, p_tot, p_onshell)
pcm_work%real_kinematics%p_born_onshell%phs_point(1) = p_onshell
if (debug2_active (D_THRESHOLD)) then
print *, 'On-shell projected Born: '
call vector4_write_set (p_onshell)
end if
end subroutine kinematics_threshold_projection
@ %def kinematics_threshold_projection
@
<<Kinematics: kinematics: TBP>>=
procedure :: evaluate_radiation => kinematics_evaluate_radiation
<<Kinematics: sub interfaces>>=
module subroutine kinematics_evaluate_radiation (k, p_in, p_out, success)
class(kinematics_t), intent(inout) :: k
type(vector4_t), intent(in), dimension(:) :: p_in
type(vector4_t), intent(out), dimension(:), allocatable :: p_out
logical, intent(out) :: success
end subroutine kinematics_evaluate_radiation
<<Kinematics: procedures>>=
module subroutine kinematics_evaluate_radiation (k, p_in, p_out, success)
class(kinematics_t), intent(inout) :: k
type(vector4_t), intent(in), dimension(:) :: p_in
type(vector4_t), intent(out), dimension(:), allocatable :: p_out
logical, intent(out) :: success
type(vector4_t), dimension(:), allocatable :: p_real
type(vector4_t), dimension(:), allocatable :: p_born
real(default) :: xi_max_offshell, xi_offshell, y_offshell, jac_rand_dummy, phi
select type (phs => k%phs)
type is (phs_fks_t)
allocate (p_born (size (p_in)))
if (k%threshold) then
p_born = phs%get_onshell_projected_momenta ()
else
p_born = p_in
end if
if (.not. k%phs%lab_is_cm () .and. .not. k%threshold) then
p_born = inverse (k%phs%lt_cm_to_lab) * p_born
end if
call phs%compute_xi_max (p_born, k%threshold)
if (k%emitter >= 0) then
allocate (p_real (size (p_born) + 1))
allocate (p_out (size (p_born) + 1))
if (k%emitter <= k%n_in) then
call phs%generate_isr (k%i_phs, p_real)
else
if (k%threshold) then
jac_rand_dummy = 1._default
call compute_y_from_emitter (phs%generator%real_kinematics%x_rad (I_Y), &
phs%generator%real_kinematics%p_born_cms%get_momenta(1), &
k%n_in, k%emitter, .false., phs%generator%y_max, jac_rand_dummy, &
y_offshell)
call phs%compute_xi_max (k%emitter, k%i_phs, y_offshell, &
phs%generator%real_kinematics%p_born_cms%get_momenta(1), &
xi_max_offshell)
xi_offshell = xi_max_offshell * phs%generator%real_kinematics%xi_tilde
phi = phs%generator%real_kinematics%phi
call phs%generate_fsr (k%emitter, k%i_phs, p_real, &
xi_y_phi = [xi_offshell, y_offshell, phi], no_jacobians = .true.)
call phs%generator%real_kinematics%p_real_cms%set_momenta (k%i_phs, p_real)
call phs%generate_fsr_threshold (k%emitter, k%i_phs, p_real)
if (debug2_active (D_SUBTRACTION)) &
call generate_fsr_threshold_for_other_emitters (k%emitter, k%i_phs)
else if (k%i_con > 0) then
call phs%generate_fsr (k%emitter, k%i_phs, p_real, k%i_con)
else
call phs%generate_fsr (k%emitter, k%i_phs, p_real)
end if
end if
success = check_scalar_products (p_real)
if (debug2_active (D_SUBTRACTION)) then
call msg_debug2 (D_SUBTRACTION, "Real phase-space: ")
call vector4_write_set (p_real)
end if
p_out = p_real
else
allocate (p_out (size (p_in))); p_out = p_in
success = .true.
end if
end select
contains
subroutine generate_fsr_threshold_for_other_emitters (emitter, i_phs)
integer, intent(in) :: emitter, i_phs
integer :: ii_phs, this_emitter
select type (phs => k%phs)
type is (phs_fks_t)
do ii_phs = 1, size (phs%phs_identifiers)
this_emitter = phs%phs_identifiers(ii_phs)%emitter
if (ii_phs /= i_phs .and. this_emitter /= emitter) &
call phs%generate_fsr_threshold (this_emitter, i_phs)
end do
end select
end subroutine
end subroutine kinematics_evaluate_radiation
@ %def kinematics_evaluate_radiation
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Instances}
<<[[instances.f90]]>>=
<<File header>>
module instances
<<Use kinds>>
<<Use strings>>
use lorentz
use mci_base
use particles
use sm_qcd, only: qcd_t
use quantum_numbers
use interactions
use model_data
use variables
use sf_base
use pdf, only: pdf_data_t
use physics_defs
use process_constants
use state_matrices
use phs_base
use prc_core, only: prc_core_t, prc_core_state_t
!!! local modules
use parton_states
use process_counter
use pcm_base
use pcm
use process_config
use process_mci
use process
use kinematics
<<Standard module head>>
<<Instances: public>>
<<Instances: types>>
<<Instances: interfaces>>
interface
<<Instances: sub interfaces>>
end interface
contains
<<Instances: main procedures>>
end module instances
@ %def instances
@
<<[[instances_sub.f90]]>>=
<<File header>>
submodule (instances) instances_s
<<Use debug>>
use io_units
use format_utils, only: write_separator
use constants
use diagnostics
use numeric_utils
use helicities
use flavors
use pdg_arrays, only: is_quark, is_charged_lepton, flv_eqv_expr_class
!!! We should depend less on these modules (move it to pcm_nlo_t e.g.)
use phs_wood, only: phs_wood_t
use phs_fks
use blha_olp_interfaces, only: prc_blha_t
use blha_config, only: BLHA_AMP_COLOR_C
use prc_omega, only: prc_omega_t, omega_state_t
use prc_external, only: prc_external_t, prc_external_state_t
use prc_threshold, only: prc_threshold_t
use blha_olp_interfaces, only: blha_result_array_size
use prc_openloops, only: prc_openloops_t, openloops_state_t
use prc_recola, only: prc_recola_t
use blha_olp_interfaces, only: blha_color_c_fill_offdiag, blha_color_c_fill_diag
use ttv_formfactors, only: m1s_to_mpole
implicit none
contains
<<Instances: procedures>>
end submodule instances_s
@ %def instances_s
@
\subsection{Term instance}
A [[term_instance_t]] object contains all data that describe a term. Each
process component consists of one or more distinct terms which may differ in
kinematics, but whose squared transition matrices have to be added pointwise.
The [[active]] flag is set when this term is connected to an active
process component. Inactive terms are skipped for kinematics and evaluation.
The [[amp]] array stores the amplitude values when we get them from evaluating
the associated matrix-element code.
The [[int_hard]] interaction describes the elementary hard process.
It receives the momenta and the amplitude entries for each sampling point.
The [[isolated]] object holds the effective parton state for the
elementary interaction. The amplitude entries are
computed from [[int_hard]].
The [[connected]] evaluator set
convolutes this scattering matrix with the beam (and possibly
structure-function) density matrix.
The [[checked]] flag is set once we have applied cuts on this term.
The result of this is stored in the [[passed]] flag.
Although each [[term_instance]] carries a [[weight]], this currently
always keeps the value $1$ and is only used to be given to routines
to fulfill their signature.
<<Instances: types>>=
type :: term_instance_t
type(process_term_t), pointer :: config => null ()
class(pcm_t), pointer :: pcm => null ()
class(pcm_workspace_t), pointer :: pcm_work => null ()
logical :: active = .false.
complex(default), dimension(:), allocatable :: amp
type(interaction_t) :: int_hard
type(isolated_state_t) :: isolated
type(connected_state_t) :: connected
class(prc_core_state_t), allocatable :: core_state
logical :: checked = .false.
logical :: passed = .false.
logical, dimension(:), allocatable :: passed_array
integer, dimension(:), allocatable :: i_flv_to_i_flv_rep
real(default) :: scale = 0
real(default), allocatable :: fac_scale
real(default), allocatable :: ren_scale
real(default), allocatable :: es_scale
real(default), allocatable :: alpha_qcd_forced
real(default) :: weight = 1
type(vector4_t), dimension(:), allocatable :: p_seed
type(vector4_t), dimension(:), allocatable :: p_hard
integer :: nlo_type = BORN
integer, dimension(:), allocatable :: same_kinematics
logical :: negative_sf = .false.
logical :: flv_dep_cut_eval = .false.
contains
<<Instances: term instance: TBP>>
end type term_instance_t
@ %def term_instance_t
@
<<Instances: term instance: TBP>>=
procedure :: write => term_instance_write
<<Instances: sub interfaces>>=
module subroutine term_instance_write &
(term, unit, kin, show_eff_state, testflag)
class(term_instance_t), intent(in) :: term
integer, intent(in), optional :: unit
type(kinematics_t), intent(in), optional :: kin
logical, intent(in), optional :: show_eff_state
logical, intent(in), optional :: testflag
end subroutine term_instance_write
<<Instances: procedures>>=
module subroutine term_instance_write &
(term, unit, kin, show_eff_state, testflag)
class(term_instance_t), intent(in) :: term
integer, intent(in), optional :: unit
type(kinematics_t), intent(in), optional :: kin
logical, intent(in), optional :: show_eff_state
logical, intent(in), optional :: testflag
real(default) :: fac_scale, ren_scale
integer :: u
logical :: state
u = given_output_unit (unit)
state = .true.; if (present (show_eff_state)) state = show_eff_state
if (term%active) then
if (associated (term%config)) then
write (u, "(1x,A,I0,A,I0,A)") "Term #", term%config%i_term, &
" (component #", term%config%i_component, ")"
else
write (u, "(1x,A)") "Term [undefined]"
end if
else
write (u, "(1x,A,I0,A)") "Term #", term%config%i_term, &
" [inactive]"
end if
if (term%checked) then
write (u, "(3x,A,L1)") "passed cuts = ", term%passed
end if
if (term%passed) then
write (u, "(3x,A,ES19.12)") "overall scale = ", term%scale
write (u, "(3x,A,ES19.12)") "factorization scale = ", term%get_fac_scale ()
write (u, "(3x,A,ES19.12)") "renormalization scale = ", term%get_ren_scale ()
if (allocated (term%alpha_qcd_forced)) then
write (u, "(3x,A,ES19.12)") "alpha(QCD) forced = ", &
term%alpha_qcd_forced
end if
write (u, "(3x,A,ES19.12)") "reweighting factor = ", term%weight
end if
!!! This used to be a member of term_instance
if (present (kin)) then
call kin%write (u)
end if
call write_separator (u)
write (u, "(1x,A)") "Amplitude (transition matrix of the &
&hard interaction):"
call write_separator (u)
call term%int_hard%basic_write (u, testflag = testflag)
if (state .and. term%isolated%has_trace) then
call write_separator (u)
write (u, "(1x,A)") "Evaluators for the hard interaction:"
call term%isolated%write (u, testflag = testflag)
end if
if (state .and. term%connected%has_trace) then
call write_separator (u)
write (u, "(1x,A)") "Evaluators for the connected process:"
call term%connected%write (u, testflag = testflag)
end if
end subroutine term_instance_write
@ %def term_instance_write
@ The interactions and evaluators must be finalized.
<<Instances: term instance: TBP>>=
procedure :: final => term_instance_final
<<Instances: sub interfaces>>=
module subroutine term_instance_final (term)
class(term_instance_t), intent(inout) :: term
end subroutine term_instance_final
<<Instances: procedures>>=
module subroutine term_instance_final (term)
class(term_instance_t), intent(inout) :: term
if (allocated (term%amp)) deallocate (term%amp)
if (allocated (term%core_state)) deallocate (term%core_state)
if (allocated (term%ren_scale)) deallocate (term%ren_scale)
if (allocated (term%fac_scale)) deallocate (term%fac_scale)
if (allocated (term%es_scale)) deallocate (term%es_scale)
if (allocated (term%alpha_qcd_forced)) &
deallocate (term%alpha_qcd_forced)
if (allocated (term%p_seed)) deallocate(term%p_seed)
if (allocated (term%p_hard)) deallocate (term%p_hard)
call term%connected%final ()
call term%isolated%final ()
call term%int_hard%final ()
term%pcm => null ()
term%pcm_work => null ()
end subroutine term_instance_final
@ %def term_instance_final
@ For a new term object, we configure the structure-function
interface, the phase space, the matrix-element (interaction)
interface, etc.
<<Instances: term instance: TBP>>=
procedure :: configure => term_instance_configure
<<Instances: sub interfaces>>=
module subroutine term_instance_configure &
(term_instance, process, i, pcm_work, sf_chain, kin)
class(term_instance_t), intent(out), target :: term_instance
type(process_t), intent(in), target :: process
integer, intent(in) :: i
class(pcm_workspace_t), intent(in), target :: pcm_work
type(sf_chain_t), intent(in), target :: sf_chain
type(kinematics_t), intent(inout), target :: kin
end subroutine term_instance_configure
<<Instances: procedures>>=
module subroutine term_instance_configure &
(term_instance, process, i, pcm_work, sf_chain, kin)
class(term_instance_t), intent(out), target :: term_instance
type(process_t), intent(in), target :: process
integer, intent(in) :: i
class(pcm_workspace_t), intent(in), target :: pcm_work
type(sf_chain_t), intent(in), target :: sf_chain
type(kinematics_t), intent(inout), target :: kin
type(process_term_t) :: term
integer :: i_component
logical :: requires_extended_sf
term = process%get_term_ptr (i)
i_component = term%i_component
if (i_component /= 0) then
call term_instance%init &
(process%get_pcm_ptr (), pcm_work, process%get_nlo_type_component (i_component))
requires_extended_sf = term_instance%nlo_type == NLO_DGLAP .or. &
(term_instance%nlo_type == NLO_REAL .and. process%get_i_sub (i) == i)
call term_instance%setup_dynamics (process, i, kin, &
real_finite = process%component_is_real_finite (i_component))
select type (phs => kin%phs)
type is (phs_fks_t)
call term_instance%set_emitter (kin)
call term_instance%setup_fks_kinematics (kin, &
process%get_var_list_ptr (), &
process%get_beam_config_ptr ())
end select
select type (pcm => term_instance%pcm)
type is (pcm_nlo_t)
call kin%set_threshold (pcm%settings%factorization_mode)
end select
call term_instance%setup_expressions (process%get_meta (), process%get_config ())
end if
end subroutine term_instance_configure
@ %def term_instance_configure
@ First part of term-instance configuration: initialize by assigning
pointers to the overall [[pcm]] and the associated [[pcm_workspace]]
objects.
<<Instances: term instance: TBP>>=
procedure :: init => term_instance_init
<<Instances: sub interfaces>>=
module subroutine term_instance_init &
(term_instance, pcm, pcm_work, nlo_type)
class(term_instance_t), intent(out) :: term_instance
class(pcm_t), intent(in), target :: pcm
class(pcm_workspace_t), intent(in), target :: pcm_work
integer, intent(in) :: nlo_type
end subroutine term_instance_init
<<Instances: procedures>>=
module subroutine term_instance_init (term_instance, pcm, pcm_work, nlo_type)
class(term_instance_t), intent(out) :: term_instance
class(pcm_t), intent(in), target :: pcm
class(pcm_workspace_t), intent(in), target :: pcm_work
integer, intent(in) :: nlo_type
term_instance%pcm => pcm
term_instance%pcm_work => pcm_work
term_instance%nlo_type = nlo_type
end subroutine term_instance_init
@ %def term_instance_init
@ The second part of term-instance configuration concerns dynamics, i.e., the
interface to the matrix-element (interaction), and the parton-state
objects that combine all kinematics and matrix-element data for evaluation.
The hard interaction (incoming momenta) is linked to the structure
function instance. In the isolated state, we either set pointers to
both, or we create modified copies ([[rearrange]]) as effective
structure-function chain and interaction, respectively.
Finally, we set up the [[subevt]] component that will be used for
evaluating observables, collecting particles from the trace evaluator
in the effective connected state. Their quantum numbers must be
determined by following back source links and set explicitly, since
they are already eliminated in that trace.
The [[rearrange]] parts are still commented out; they could become
relevant for a NLO algorithm.
<<Instances: term instance: TBP>>=
procedure :: setup_dynamics => term_instance_setup_dynamics
<<Instances: sub interfaces>>=
module subroutine term_instance_setup_dynamics &
(term, process, i_term, kin, real_finite)
class(term_instance_t), intent(inout), target :: term
type(process_t), intent(in), target:: process
integer, intent(in) :: i_term
type(kinematics_t), intent(in) :: kin
logical, intent(in), optional :: real_finite
end subroutine term_instance_setup_dynamics
<<Instances: procedures>>=
module subroutine term_instance_setup_dynamics &
(term, process, i_term, kin, real_finite)
class(term_instance_t), intent(inout), target :: term
type(process_t), intent(in), target:: process
integer, intent(in) :: i_term
type(kinematics_t), intent(in) :: kin
logical, intent(in), optional :: real_finite
class(prc_core_t), pointer :: core => null ()
type(process_beam_config_t) :: beam_config
type(interaction_t), pointer :: sf_chain_int
type(interaction_t), pointer :: src_int
type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
type(state_matrix_t), pointer :: state_matrix
type(flavor_t), dimension(:), allocatable :: flv_int, flv_src, f_in, f_out
integer, dimension(:,:), allocatable :: flv_born, flv_real
type(flavor_t), dimension(:,:), allocatable :: flv_pdf
type(quantum_numbers_t), dimension(:,:), allocatable :: qn_pdf
integer :: n_in, n_vir, n_out, n_tot, n_sub
integer :: n_flv_born, n_flv_real, n_flv_total
integer :: i, j
logical :: me_already_squared, keep_fs_flavors
logical :: decrease_n_tot
logical :: requires_extended_sf
me_already_squared = .false.
keep_fs_flavors = .false.
term%config => process%get_term_ptr (i_term)
term%int_hard = term%config%int
core => process%get_core_term (i_term)
term%negative_sf = process%get_negative_sf ()
call core%allocate_workspace (term%core_state)
select type (core)
class is (prc_external_t)
call reduce_interaction (term%int_hard, &
core%includes_polarization (), .true., .false.)
me_already_squared = .true.
allocate (term%amp (term%int_hard%get_n_matrix_elements ()))
class default
allocate (term%amp (term%config%n_allowed))
end select
if (allocated (term%core_state)) then
select type (core_state => term%core_state)
type is (openloops_state_t)
call core_state%init_threshold (process%get_model_ptr ())
end select
end if
term%amp = cmplx (0, 0, default)
decrease_n_tot = term%nlo_type == NLO_REAL .and. &
term%config%i_term_global /= term%config%i_sub
if (present (real_finite)) then
if (real_finite) decrease_n_tot = .false.
end if
if (decrease_n_tot) then
allocate (term%p_seed (term%int_hard%get_n_tot () - 1))
else
allocate (term%p_seed (term%int_hard%get_n_tot ()))
end if
allocate (term%p_hard (term%int_hard%get_n_tot ()))
sf_chain_int => kin%sf_chain%get_out_int_ptr ()
n_in = term%int_hard%get_n_in ()
do j = 1, n_in
i = kin%sf_chain%get_out_i (j)
call term%int_hard%set_source_link (j, sf_chain_int, i)
end do
call term%isolated%init (kin%sf_chain, term%int_hard)
allocate (mask_in (n_in))
mask_in = kin%sf_chain%get_out_mask ()
select type (phs => kin%phs)
type is (phs_wood_t)
if (me_already_squared) then
call term%isolated%setup_identity_trace &
(core, mask_in, .true., .false.)
else
call term%isolated%setup_square_trace &
(core, mask_in, term%config%col, .false.)
end if
type is (phs_fks_t)
select case (phs%mode)
case (PHS_MODE_ADDITIONAL_PARTICLE)
if (me_already_squared) then
call term%isolated%setup_identity_trace &
(core, mask_in, .true., .false.)
else
keep_fs_flavors = term%config%data%n_flv > 1
call term%isolated%setup_square_trace &
(core, mask_in, term%config%col, &
keep_fs_flavors)
end if
case (PHS_MODE_COLLINEAR_REMNANT)
if (me_already_squared) then
call term%isolated%setup_identity_trace &
(core, mask_in, .true., .false.)
else
call term%isolated%setup_square_trace &
(core, mask_in, term%config%col, .false.)
end if
end select
class default
call term%isolated%setup_square_trace &
(core, mask_in, term%config%col, .false.)
end select
if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL .and. &
term%config%i_term_global == term%config%i_sub) .or. &
term%nlo_type == NLO_MISMATCH) then
n_sub = term%get_n_sub ()
else if (term%nlo_type == NLO_DGLAP) then
n_sub = n_beams_rescaled + term%get_n_sub ()
else
!!! No integration of real subtraction in interactions yet
n_sub = 0
end if
keep_fs_flavors = keep_fs_flavors .or. me_already_squared
requires_extended_sf = term%nlo_type == NLO_DGLAP .or. &
(term%is_subtraction () .and. process%pcm_contains_pdfs ())
call term%connected%setup_connected_trace (term%isolated, &
undo_helicities = undo_helicities (core, me_already_squared), &
keep_fs_flavors = keep_fs_flavors, &
requires_extended_sf = requires_extended_sf)
associate (int_eff => term%isolated%int_eff)
state_matrix => int_eff%get_state_matrix_ptr ()
n_tot = int_eff%get_n_tot ()
flv_int = quantum_numbers_get_flavor &
(state_matrix%get_quantum_number (1))
allocate (f_in (n_in))
f_in = flv_int(1:n_in)
deallocate (flv_int)
end associate
n_in = term%connected%trace%get_n_in ()
n_vir = term%connected%trace%get_n_vir ()
n_out = term%connected%trace%get_n_out ()
allocate (f_out (n_out))
do j = 1, n_out
call term%connected%trace%find_source &
(n_in + n_vir + j, src_int, i)
if (associated (src_int)) then
state_matrix => src_int%get_state_matrix_ptr ()
flv_src = quantum_numbers_get_flavor &
(state_matrix%get_quantum_number (1))
f_out(j) = flv_src(i)
deallocate (flv_src)
end if
end do
beam_config = process%get_beam_config ()
select type (pcm => term%pcm)
type is (pcm_nlo_t)
term%flv_dep_cut_eval = pcm%settings%nlo_correction_type == "EW" &
.and. pcm%region_data%alphas_power > 0 &
.and. any(is_charged_lepton(f_out%get_pdg()))
end select
call term%connected%setup_subevt (term%isolated%sf_chain_eff, &
beam_config%data%flv, f_in, f_out)
call term%connected%setup_var_list &
(process%get_var_list_ptr (), beam_config%data)
! Does connected%trace never have any helicity qn?
call term%init_interaction_qn_index (core, term%connected%trace, n_sub, &
process%get_model_ptr (), is_polarized = .false.)
call term%init_interaction_qn_index &
(core, term%int_hard, n_sub, process%get_model_ptr ())
call term%init_eqv_expr_classes ()
if (requires_extended_sf) then
select type (pcm => term%pcm)
type is (pcm_nlo_t)
n_in = pcm%region_data%get_n_in ()
flv_born = pcm%region_data%get_flv_states_born ()
flv_real = pcm%region_data%get_flv_states_real ()
n_flv_born = pcm%region_data%get_n_flv_born ()
n_flv_real = pcm%region_data%get_n_flv_real ()
n_flv_total = n_flv_born + n_flv_real
allocate (flv_pdf(n_in, n_flv_total), &
qn_pdf(n_in, n_flv_total))
call flv_pdf(:, :n_flv_born)%init (flv_born(:n_in, :))
call flv_pdf(:, n_flv_born + 1:n_flv_total)%init (flv_real(:n_in, :))
call qn_pdf%init (flv_pdf)
call sf_chain_int%init_qn_index (qn_pdf, n_flv_born, n_flv_real)
end select
end if
contains
function undo_helicities (core, me_squared) result (val)
logical :: val
class(prc_core_t), intent(in) :: core
logical, intent(in) :: me_squared
select type (core)
class is (prc_external_t)
val = me_squared .and. .not. core%includes_polarization ()
class default
val = .false.
end select
end function undo_helicities
subroutine reduce_interaction (int, polarized_beams, keep_fs_flavors, &
keep_colors)
type(interaction_t), intent(inout) :: int
logical, intent(in) :: polarized_beams
logical, intent(in) :: keep_fs_flavors, keep_colors
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
logical, dimension(:), allocatable :: mask_f, mask_c, mask_h
integer :: n_tot, n_in
n_in = int%get_n_in (); n_tot = int%get_n_tot ()
allocate (qn_mask (n_tot))
allocate (mask_f (n_tot), mask_c (n_tot), mask_h (n_tot))
mask_c = .not. keep_colors
mask_f (1 : n_in) = .false.
if (keep_fs_flavors) then
mask_f (n_in + 1 : ) = .false.
else
mask_f (n_in + 1 : ) = .true.
end if
if (polarized_beams) then
mask_h (1 : n_in) = .false.
else
mask_h (1 : n_in) = .true.
end if
mask_h (n_in + 1 : ) = .true.
call qn_mask%init (mask_f, mask_c, mask_h)
call int%reduce_state_matrix (qn_mask, keep_order = .true.)
end subroutine reduce_interaction
end subroutine term_instance_setup_dynamics
@ %def term_instance_setup_dynamics
@ Set up index mapping from state matrix to index pair [[i_flv]], [[i_sub]].
<<Instances: public>>=
public :: setup_interaction_qn_index
<<Instances: sub interfaces>>=
module subroutine setup_interaction_qn_index &
(int, data, qn_config, n_sub, is_polarized)
class(interaction_t), intent(inout) :: int
class(process_constants_t), intent(in) :: data
type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_config
integer, intent(in) :: n_sub
logical, intent(in) :: is_polarized
end subroutine setup_interaction_qn_index
<<Instances: procedures>>=
module subroutine setup_interaction_qn_index &
(int, data, qn_config, n_sub, is_polarized)
class(interaction_t), intent(inout) :: int
class(process_constants_t), intent(in) :: data
type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_config
integer, intent(in) :: n_sub
logical, intent(in) :: is_polarized
integer :: i
type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel
if (is_polarized) then
call setup_interaction_qn_hel (int, data, qn_hel)
call int%init_qn_index (qn_config, n_sub, qn_hel)
call int%set_qn_index_helicity_flip (.true.)
else
call int%init_qn_index (qn_config, n_sub)
end if
end subroutine setup_interaction_qn_index
@ %def setup_interaction_qn_index
@ Set up beam polarisation quantum numbers, if beam polarisation is required.
We retrieve the full helicity information from [[term%config%data]] and reduce
the information only to the inital state. Afterwards, we uniquify the initial
state polarization by a applying an index (hash) table.
The helicity information is fed into an array of quantum numbers to assign
flavor, helicity and subtraction indices correctly to their matrix element.
<<Instances: public>>=
public :: setup_interaction_qn_hel
<<Instances: sub interfaces>>=
module subroutine setup_interaction_qn_hel (int, data, qn_hel)
class(interaction_t), intent(in) :: int
class(process_constants_t), intent(in) :: data
type(quantum_numbers_t), dimension(:, :), allocatable, intent(out) :: &
qn_hel
end subroutine setup_interaction_qn_hel
<<Instances: procedures>>=
module subroutine setup_interaction_qn_hel (int, data, qn_hel)
class(interaction_t), intent(in) :: int
class(process_constants_t), intent(in) :: data
type(quantum_numbers_t), dimension(:, :), allocatable, intent(out) :: &
qn_hel
type(helicity_t), dimension(:), allocatable :: hel
integer, dimension(:), allocatable :: index_table
integer, dimension(:, :), allocatable :: hel_state
integer :: i, j, n_hel_unique
associate (n_in => int%get_n_in (), n_tot => int%get_n_tot ())
allocate (hel_state (n_tot, data%get_n_hel ()), &
source = data%hel_state)
allocate (index_table (data%get_n_hel ()), &
source = 0)
forall (j=1:data%get_n_hel (), i=n_in+1:n_tot) hel_state(i, j) = 0
n_hel_unique = 0
HELICITY: do i = 1, data%get_n_hel ()
do j = 1, data%get_n_hel ()
if (index_table (j) == 0) then
index_table(j) = i; n_hel_unique = n_hel_unique + 1
cycle HELICITY
else if (all (hel_state(:, i) == &
hel_state(:, index_table(j)))) then
cycle HELICITY
end if
end do
end do HELICITY
allocate (qn_hel (n_tot, n_hel_unique))
allocate (hel (n_tot))
do j = 1, n_hel_unique
call hel%init (hel_state(:, index_table(j)))
call qn_hel(:, j)%init (hel)
end do
end associate
end subroutine setup_interaction_qn_hel
@ %def setup_interaction_qn_hel
@ Initialization of equivalent cut expression classes.
Each flavor index [[i_flv]] here is assigned to the corresponding one
representative for an equivalent cut expression class. This class describes
the set of flavor quantum numbers for which the phase space cut expression
evaluation yield the same output. The representative [[i_flv]] for one class
correspond to the first flavor quantum numbers of that kind occuring in the
state matrix.
<<Instances: term instance: TBP>>=
procedure :: init_eqv_expr_classes => term_instance_init_eqv_expr_classes
<<Instances: sub interfaces>>=
module subroutine term_instance_init_eqv_expr_classes (term)
class(term_instance_t), intent(inout), target :: term
end subroutine term_instance_init_eqv_expr_classes
<<Instances: procedures>>=
module subroutine term_instance_init_eqv_expr_classes (term)
class(term_instance_t), intent(inout), target :: term
type(interaction_t), pointer :: src_int
type(state_matrix_t), pointer :: state_matrix
type(flavor_t), dimension(:), allocatable :: flv_src
logical, dimension(:,:,:), allocatable :: eqv_expr_class
logical, dimension (:), allocatable :: evaluated
integer :: n_in, n_vir, n_out
integer :: k, j, i
n_in = term%connected%trace%get_n_in ()
n_vir = term%connected%trace%get_n_vir ()
n_out = term%connected%trace%get_n_out ()
allocate (eqv_expr_class (3, n_out, &
term%connected%trace%get_qn_index_n_flv ()))
do k = 1, term%connected%trace%get_qn_index_n_flv ()
do j = 1, n_out
call term%connected%trace%find_source &
(n_in + n_vir + j, src_int, i)
if (associated (src_int)) then
state_matrix => src_int%get_state_matrix_ptr ()
flv_src = quantum_numbers_get_flavor &
(state_matrix%get_quantum_number (k))
eqv_expr_class (:, j, k) = flv_eqv_expr_class (flv_src(i)%get_pdg())
deallocate (flv_src)
end if
end do
end do
if (term%flv_dep_cut_eval) then
allocate (evaluated (term%connected%trace%get_qn_index_n_flv ()))
evaluated = .false.
allocate (term%i_flv_to_i_flv_rep (term%connected%trace%get_qn_index_n_flv ()))
do i = 1, term%connected%trace%get_qn_index_n_flv ()
if (.not. evaluated (i)) then
do k = i, term%connected%trace%get_qn_index_n_flv ()
if (same_eqv_expr_class(eqv_expr_class (:,:,i), eqv_expr_class (:,:,k))) then
term%i_flv_to_i_flv_rep (k) = i
evaluated (k) = .true.
end if
end do
end if
end do
end if
contains
function same_eqv_expr_class (flv_mask1, flv_mask2) result (same)
logical, dimension (:,:), intent(in) :: flv_mask1, flv_mask2
logical :: same
integer :: l
same = .true.
do l = 1, size (flv_mask1, dim = 2)
same = same .and. all (flv_mask1(:,l) .eqv. flv_mask2(:,l))
end do
end function same_eqv_expr_class
end subroutine term_instance_init_eqv_expr_classes
@ %def term_instance_init_eqv_expr_classes
@
<<Instances: term instance: TBP>>=
procedure :: init_interaction_qn_index => &
term_instance_init_interaction_qn_index
<<Instances: sub interfaces>>=
module subroutine term_instance_init_interaction_qn_index (term, core, &
int, n_sub, model, is_polarized)
class(term_instance_t), intent(inout), target :: term
class(prc_core_t), intent(in) :: core
class(interaction_t), intent(inout) :: int
integer, intent(in) :: n_sub
class(model_data_t), intent(in) :: model
logical, intent(in), optional :: is_polarized
end subroutine term_instance_init_interaction_qn_index
<<Instances: procedures>>=
module subroutine term_instance_init_interaction_qn_index (term, core, &
int, n_sub, model, is_polarized)
class(term_instance_t), intent(inout), target :: term
class(prc_core_t), intent(in) :: core
class(interaction_t), intent(inout) :: int
integer, intent(in) :: n_sub
class(model_data_t), intent(in) :: model
logical, intent(in), optional :: is_polarized
logical :: polarized
type(quantum_numbers_t), dimension(:, :), allocatable :: qn_config
integer, dimension(:,:), allocatable :: flv_born
type(flavor_t), dimension(:), allocatable :: flv
integer :: i
select type (core)
class is (prc_external_t)
if (present (is_polarized)) then
polarized = is_polarized
else
polarized = core%includes_polarization ()
end if
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
associate (is_born => .not. (term%nlo_type == NLO_REAL .and. &
.not. term%is_subtraction ()))
select type (pcm => term%pcm)
type is (pcm_nlo_t)
qn_config = pcm%get_qn (is_born)
end select
call setup_interaction_qn_index (int, term%config%data, &
qn_config, n_sub, polarized)
end associate
class default
call term%config%data%get_flv_state (flv_born)
allocate (flv (size (flv_born, dim = 1)))
allocate (qn_config (size (flv_born, dim = 1), size (flv_born, dim = 2)))
do i = 1, core%data%n_flv
call flv%init (flv_born(:,i), model)
call qn_config(:, i)%init (flv)
end do
call setup_interaction_qn_index (int, term%config%data, &
qn_config, n_sub, polarized)
end select
class default
call int%init_qn_index ()
end select
end subroutine term_instance_init_interaction_qn_index
@ %def term_instance_init_interaction_qn_index
@
<<Instances: term instance: TBP>>=
procedure :: setup_fks_kinematics => term_instance_setup_fks_kinematics
<<Instances: sub interfaces>>=
module subroutine term_instance_setup_fks_kinematics &
(term, kin, var_list, beam_config)
class(term_instance_t), intent(inout), target :: term
type(kinematics_t), intent(inout) :: kin
type(var_list_t), intent(in) :: var_list
type(process_beam_config_t), intent(in) :: beam_config
end subroutine term_instance_setup_fks_kinematics
<<Instances: procedures>>=
module subroutine term_instance_setup_fks_kinematics &
(term, kin, var_list, beam_config)
class(term_instance_t), intent(inout), target :: term
type(kinematics_t), intent(inout) :: kin
type(var_list_t), intent(in) :: var_list
type(process_beam_config_t), intent(in) :: beam_config
integer :: mode
logical :: singular_jacobian
if (.not. (term%nlo_type == NLO_REAL .or. term%nlo_type == NLO_DGLAP .or. &
term%nlo_type == NLO_MISMATCH)) return
singular_jacobian = var_list%get_lval &
(var_str ("?powheg_use_singular_jacobian"))
if (term%nlo_type == NLO_REAL) then
mode = check_generator_mode (GEN_REAL_PHASE_SPACE)
else if (term%nlo_type == NLO_MISMATCH) then
mode = check_generator_mode (GEN_SOFT_MISMATCH)
else
mode = PHS_MODE_UNDEFINED
end if
select type (phs => kin%phs)
type is (phs_fks_t)
select type (pcm => term%pcm)
type is (pcm_nlo_t)
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
call pcm%setup_phs_generator (pcm_work, &
phs%generator, phs%config%sqrts, mode, singular_jacobian)
if (beam_config%has_structure_function ()) then
pcm_work%isr_kinematics%isr_mode = SQRTS_VAR
else
pcm_work%isr_kinematics%isr_mode = SQRTS_FIXED
end if
if (debug_on) call msg_debug &
(D_PHASESPACE, "isr_mode: ", pcm_work%isr_kinematics%isr_mode)
end select
end select
class default
call msg_fatal ("Phase space should be an FKS phase space!")
end select
contains
function check_generator_mode (gen_mode_default) result (gen_mode)
integer :: gen_mode
integer, intent(in) :: gen_mode_default
select type (pcm => term%pcm)
type is (pcm_nlo_t)
associate (settings => pcm%settings)
if (settings%test_coll_limit .and. settings%test_anti_coll_limit) &
call msg_fatal ("You cannot check the collinear and anti-collinear limit "&
&"at the same time!")
if (settings%test_soft_limit .and. .not. settings%test_coll_limit &
.and. .not. settings%test_anti_coll_limit) then
gen_mode = GEN_SOFT_LIMIT_TEST
else if (.not. settings%test_soft_limit .and. settings%test_coll_limit) then
gen_mode = GEN_COLL_LIMIT_TEST
else if (.not. settings%test_soft_limit .and. settings%test_anti_coll_limit) then
gen_mode = GEN_ANTI_COLL_LIMIT_TEST
else if (settings%test_soft_limit .and. settings%test_coll_limit) then
gen_mode = GEN_SOFT_COLL_LIMIT_TEST
else if (settings%test_soft_limit .and. settings%test_anti_coll_limit) then
gen_mode = GEN_SOFT_ANTI_COLL_LIMIT_TEST
else
gen_mode = gen_mode_default
end if
end associate
end select
end function check_generator_mode
end subroutine term_instance_setup_fks_kinematics
@ %def term_instance_setup_fks_kinematics
@ Set up seed kinematics, starting from the MC parameter set given as
argument. As a result, the [[k_seed]] kinematics object is evaluated
(except for the structure-function matrix-element evaluation, which we
postpone until we know the factorization scale), and we have a valid
[[p_seed]] momentum array.
<<Instances: term instance: TBP>>=
procedure :: compute_seed_kinematics => term_instance_compute_seed_kinematics
<<Instances: sub interfaces>>=
module subroutine term_instance_compute_seed_kinematics &
(term, kin, mci_work, phs_channel, success)
class(term_instance_t), intent(inout), target :: term
type(kinematics_t), intent(inout) :: kin
type(mci_work_t), intent(in) :: mci_work
integer, intent(in) :: phs_channel
logical, intent(out) :: success
end subroutine term_instance_compute_seed_kinematics
<<Instances: procedures>>=
module subroutine term_instance_compute_seed_kinematics &
(term, kin, mci_work, phs_channel, success)
class(term_instance_t), intent(inout), target :: term
type(kinematics_t), intent(inout) :: kin
type(mci_work_t), intent(in) :: mci_work
integer, intent(in) :: phs_channel
logical, intent(out) :: success
call kin%compute_selected_channel &
(mci_work, phs_channel, term%p_seed, success)
end subroutine term_instance_compute_seed_kinematics
@ %def term_instance_compute_seed_kinematics
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_projections => term_instance_evaluate_projections
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_projections (term, kin)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(inout) :: kin
end subroutine term_instance_evaluate_projections
<<Instances: procedures>>=
module subroutine term_instance_evaluate_projections (term, kin)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(inout) :: kin
if (kin%threshold .and. term%nlo_type > BORN) then
if (debug2_active (D_THRESHOLD)) &
print *, 'Evaluate on-shell projection: ', &
char (component_status (term%nlo_type))
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
call kin%threshold_projection (pcm_work, term%nlo_type)
end select
end if
end subroutine term_instance_evaluate_projections
@ %def term_instance_evaluate_projections
@ Compute the momenta in the hard interactions, one for each term that
constitutes this process component. In simple cases this amounts to
just copying momenta. In more advanced cases, we may generate
distinct sets of momenta from the seed kinematics.
The interactions in the term instances are accessed individually. We may
choose to calculate all terms at once together with the seed kinematics, use
[[component%core_state]] for storage, and just fill the interactions here.
<<Instances: term instance: TBP>>=
procedure :: compute_hard_kinematics => &
term_instance_compute_hard_kinematics
<<Instances: sub interfaces>>=
module subroutine term_instance_compute_hard_kinematics &
(term, kin, recover, skip_term, success)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(inout) :: kin
integer, intent(in), optional :: skip_term
logical, intent(in), optional :: recover
logical, intent(out) :: success
end subroutine term_instance_compute_hard_kinematics
<<Instances: procedures>>=
module subroutine term_instance_compute_hard_kinematics &
(term, kin, recover, skip_term, success)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(inout) :: kin
integer, intent(in), optional :: skip_term
logical, intent(in), optional :: recover
logical, intent(out) :: success
type(vector4_t), dimension(:), allocatable :: p
if (allocated (term%core_state)) &
call term%core_state%reset_new_kinematics ()
if (present (skip_term)) then
if (term%config%i_term_global == skip_term) return
end if
if (present (recover)) then
if (recover) return
end if
if (term%nlo_type == NLO_REAL .and. kin%emitter >= 0) then
call kin%evaluate_radiation (term%p_seed, p, success)
select type (pcm => term%pcm)
type is (pcm_nlo_t)
if (pcm%dalitz_plot%active) then
if (kin%emitter > kin%n_in) then
if (p(kin%emitter)**2 > tiny_07) &
call pcm%register_dalitz_plot (kin%emitter, p)
end if
end if
end select
else if (is_subtraction_component (kin%emitter, term%nlo_type)) then
call kin%modify_momenta_for_subtraction (term%p_seed, p)
success = .true.
else
allocate (p (size (term%p_seed))); p = term%p_seed
success = .true.
end if
call term%int_hard%set_momenta (p)
if (debug_on) then
call msg_debug2 (D_REAL, "inside compute_hard_kinematics")
if (debug2_active (D_REAL)) call vector4_write_set (p)
end if
end subroutine term_instance_compute_hard_kinematics
@ %def term_instance_compute_hard_kinematics
@ Here, we invert this. We fetch the incoming momenta which reside
in the appropriate [[sf_chain]] object, stored within the [[k_seed]]
subobject. On the other hand, we have the outgoing momenta of the
effective interaction. We rely on the process core to compute the
remaining seed momenta and to fill the momenta within the hard
interaction. (The latter is trivial if hard and effective interaction
coincide.)
After this is done, the incoming momenta in the trace evaluator that
corresponds to the hard (effective) interaction, are still
left undefined. We remedy this by calling [[receive_kinematics]] once.
<<Instances: term instance: TBP>>=
procedure :: recover_seed_kinematics => &
term_instance_recover_seed_kinematics
<<Instances: sub interfaces>>=
module subroutine term_instance_recover_seed_kinematics &
(term, kin, p_seed_ref)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(in) :: kin
type(vector4_t), dimension(:), intent(in), optional :: p_seed_ref
end subroutine term_instance_recover_seed_kinematics
<<Instances: procedures>>=
module subroutine term_instance_recover_seed_kinematics &
(term, kin, p_seed_ref)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(in) :: kin
integer :: n_in
type(vector4_t), dimension(:), intent(in), optional :: p_seed_ref
n_in = kin%n_in
call kin%get_incoming_momenta (term%p_seed(1:n_in))
associate (int_eff => term%isolated%int_eff)
call int_eff%set_momenta (term%p_seed(1:n_in), outgoing = .false.)
if (present (p_seed_ref)) then
term%p_seed(n_in + 1 : ) = p_seed_ref
else
term%p_seed(n_in + 1 : ) = int_eff%get_momenta (outgoing = .true.)
end if
end associate
call term%isolated%receive_kinematics ()
end subroutine term_instance_recover_seed_kinematics
@ %def term_instance_recover_seed_kinematics
@ Compute the integration parameters for all channels except the selected
one.
JRR: Obsolete now.
<<XXX Instances: term instance: TBP>>=
procedure :: compute_other_channels => &
term_instance_compute_other_channels
<<XXX Instances: procedures>>=
subroutine term_instance_compute_other_channels &
(term, mci_work, phs_channel)
class(term_instance_t), intent(inout), target :: term
type(mci_work_t), intent(in) :: mci_work
integer, intent(in) :: phs_channel
call term%k_term%compute_other_channels (mci_work, phs_channel)
end subroutine term_instance_compute_other_channels
@ %def term_instance_compute_other_channels
@ Recover beam momenta, i.e., return the beam momenta as currently
stored in the kinematics subobject to their source. This is a side effect.
JRR: Obsolete now.
<<XXX Instances: term instance: TBP>>=
procedure :: return_beam_momenta => term_instance_return_beam_momenta
<<XXX Instances: procedures>>=
subroutine term_instance_return_beam_momenta (term)
class(term_instance_t), intent(in) :: term
call term%k_term%return_beam_momenta ()
end subroutine term_instance_return_beam_momenta
@ %def term_instance_return_beam_momenta
@
Applies the real partition by computing the real partition function $F(\Phi)$
and multiplying either $\mathcal{R}_\text{sin} = \mathcal{R} \cdot F$ or
$\mathcal{R}_\text{fin} = \mathcal{R} \cdot (1-F)$.
<<Instances: term instance: TBP>>=
procedure :: apply_real_partition => term_instance_apply_real_partition
<<Instances: sub interfaces>>=
module subroutine term_instance_apply_real_partition (term, kin)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(in) :: kin
end subroutine term_instance_apply_real_partition
<<Instances: procedures>>=
module subroutine term_instance_apply_real_partition (term, kin)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(in) :: kin
real(default) :: f, sqme
integer :: i_component
integer :: i_amp, n_amps, qn_index
logical :: is_subtraction
i_component = term%config%i_component
select type (pcm => term%pcm)
type is (pcm_nlo_t)
if (pcm%component_selected (i_component) .and. &
pcm%nlo_type (i_component) == NLO_REAL) then
is_subtraction = pcm%component_type (i_component) == &
COMP_REAL_SING .and. kin%emitter < 0
if (is_subtraction) return
select case (pcm%component_type (i_component))
case (COMP_REAL_FIN)
call term%connected%trace%set_duplicate_flv_zero()
end select
f = pcm%real_partition%get_f (term%p_hard)
n_amps = term%connected%trace%get_n_matrix_elements ()
do i_amp = 1, n_amps
qn_index = term%connected%trace%get_qn_index (i_amp, i_sub = 0)
if (term%passed_array(i_amp) .or. .not. term%passed) then
sqme = real (term%connected%trace%get_matrix_element (qn_index))
else
sqme = zero
end if
if (debug_on) call msg_debug2 &
(D_PROCESS_INTEGRATION, "term_instance_apply_real_partition")
select case (pcm%component_type (i_component))
case (COMP_REAL_FIN)
if (debug_on) call msg_debug2 &
(D_PROCESS_INTEGRATION, "Real finite")
sqme = sqme * (one - f)
case (COMP_REAL_SING)
if (debug_on) call msg_debug2 &
(D_PROCESS_INTEGRATION, "Real singular")
sqme = sqme * f
end select
if (debug_on) call msg_debug2 &
(D_PROCESS_INTEGRATION, "apply_damping: sqme", sqme)
call term%connected%trace%set_matrix_element &
(qn_index, cmplx (sqme, zero, default))
end do
end if
end select
end subroutine term_instance_apply_real_partition
@ %def term_instance_apply_real_partition
@
<<Instances: term instance: TBP>>=
procedure :: get_p_hard => term_instance_get_p_hard
<<Instances: sub interfaces>>=
pure module function term_instance_get_p_hard &
(term_instance) result (p_hard)
type(vector4_t), dimension(:), allocatable :: p_hard
class(term_instance_t), intent(in) :: term_instance
end function term_instance_get_p_hard
<<Instances: procedures>>=
pure module function term_instance_get_p_hard (term_instance) result (p_hard)
type(vector4_t), dimension(:), allocatable :: p_hard
class(term_instance_t), intent(in) :: term_instance
allocate (p_hard (size (term_instance%p_hard)))
p_hard = term_instance%p_hard
end function term_instance_get_p_hard
@ %def term_instance_get_p_hard
@
<<Instances: term instance: TBP>>=
procedure :: set_emitter => term_instance_set_emitter
<<Instances: sub interfaces>>=
module subroutine term_instance_set_emitter (term, kin)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(inout) :: kin
end subroutine term_instance_set_emitter
<<Instances: procedures>>=
module subroutine term_instance_set_emitter (term, kin)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(inout) :: kin
integer :: i_phs
logical :: set_emitter
select type (pcm => term%pcm)
type is (pcm_nlo_t)
select type (phs => kin%phs)
type is (phs_fks_t)
!!! Without resonances, i_alr = i_phs
i_phs = term%config%i_term
kin%i_phs = i_phs
set_emitter = i_phs <= pcm%region_data%n_phs .and. &
term%nlo_type == NLO_REAL
if (set_emitter) then
kin%emitter = phs%phs_identifiers(i_phs)%emitter
select type (pcm => term%pcm)
type is (pcm_nlo_t)
if (allocated (pcm%region_data%i_phs_to_i_con)) &
kin%i_con = pcm%region_data%i_phs_to_i_con (i_phs)
end select
end if
end select
end select
end subroutine term_instance_set_emitter
@ %def term_instance_set_emitter
@ For initializing the expressions, we need the local variable list and the
parse trees.
<<Instances: term instance: TBP>>=
procedure :: setup_expressions => term_instance_setup_expressions
<<Instances: sub interfaces>>=
module subroutine term_instance_setup_expressions (term, meta, config)
class(term_instance_t), intent(inout), target :: term
type(process_metadata_t), intent(in), target :: meta
type(process_config_data_t), intent(in) :: config
end subroutine term_instance_setup_expressions
<<Instances: procedures>>=
module subroutine term_instance_setup_expressions (term, meta, config)
class(term_instance_t), intent(inout), target :: term
type(process_metadata_t), intent(in), target :: meta
type(process_config_data_t), intent(in) :: config
if (allocated (config%ef_cuts)) &
call term%connected%setup_cuts (config%ef_cuts)
if (allocated (config%ef_scale)) &
call term%connected%setup_scale (config%ef_scale)
if (allocated (config%ef_fac_scale)) &
call term%connected%setup_fac_scale (config%ef_fac_scale)
if (allocated (config%ef_ren_scale)) &
call term%connected%setup_ren_scale (config%ef_ren_scale)
if (allocated (config%ef_weight)) &
call term%connected%setup_weight (config%ef_weight)
end subroutine term_instance_setup_expressions
@ %def term_instance_setup_expressions
@ Prepare the extra evaluators that we need for processing events.
The matrix elements we get from OpenLoops and GoSam are already squared
and summed over color and helicity. They should not be squared again.
<<Instances: term instance: TBP>>=
procedure :: setup_event_data => term_instance_setup_event_data
<<Instances: sub interfaces>>=
module subroutine term_instance_setup_event_data (term, kin, core, model)
class(term_instance_t), intent(inout), target :: term
type(kinematics_t), intent(in) :: kin
class(prc_core_t), intent(in) :: core
class(model_data_t), intent(in), target :: model
end subroutine term_instance_setup_event_data
<<Instances: procedures>>=
module subroutine term_instance_setup_event_data (term, kin, core, model)
class(term_instance_t), intent(inout), target :: term
type(kinematics_t), intent(in) :: kin
class(prc_core_t), intent(in) :: core
class(model_data_t), intent(in), target :: model
integer :: n_in
logical :: mask_color
type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
n_in = term%int_hard%get_n_in ()
allocate (mask_in (n_in))
mask_in = kin%sf_chain%get_out_mask ()
call setup_isolated (term%isolated, core, model, mask_in, term%config%col)
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
mask_color = pcm_work%is_fixed_order_nlo_events ()
class default
mask_color = .false.
end select
call setup_connected (term%connected, term%isolated, core, &
term%nlo_type, mask_color)
contains
subroutine setup_isolated (isolated, core, model, mask, color)
type(isolated_state_t), intent(inout), target :: isolated
class(prc_core_t), intent(in) :: core
class(model_data_t), intent(in), target :: model
type(quantum_numbers_mask_t), intent(in), dimension(:) :: mask
integer, intent(in), dimension(:) :: color
select type (core)
class is (prc_blha_t)
call isolated%matrix%init_identity(isolated%int_eff)
isolated%has_matrix = .true.
class default
call isolated%setup_square_matrix (core, model, mask, color)
end select
!!! TODO (PS-09-10-20) We should not square the flows
!!! if they come from BLHA either
call isolated%setup_square_flows (core, model, mask)
end subroutine setup_isolated
subroutine setup_connected (connected, isolated, core, nlo_type, mask_color)
type(connected_state_t), intent(inout), target :: connected
type(isolated_state_t), intent(in), target :: isolated
class(prc_core_t), intent(in) :: core
integer, intent(in) :: nlo_type
logical, intent(in) :: mask_color
type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
call connected%setup_connected_matrix (isolated)
if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL &
.and. term%config%i_term_global == term%config%i_sub) &
.or. term%nlo_type == NLO_DGLAP) then
!!! We do not care about the subtraction matrix elements in
!!! connected%matrix, because all entries there are supposed
!!! to be squared. To be able to match with flavor quantum numbers,
!!! we remove the subtraction quantum entries from the state matrix.
allocate (mask (connected%matrix%get_n_tot()))
call mask%set_sub (1)
call connected%matrix%reduce_state_matrix (mask, keep_order = .true.)
end if
call term%init_interaction_qn_index (core, connected%matrix, 0, model, &
is_polarized = .false.)
select type (core)
class is (prc_blha_t)
call connected%setup_connected_flows &
(isolated, mask_color = mask_color)
class default
call connected%setup_connected_flows (isolated)
end select
call connected%setup_state_flv (isolated%get_n_out ())
end subroutine setup_connected
end subroutine term_instance_setup_event_data
@ %def term_instance_setup_event_data
@ Color-correlated matrix elements should be obtained from
the external BLHA provider. According to the standard, the
matrix elements output is a one-dimensional array. For FKS
subtraction, we require the matrix $B_{ij}$. BLHA prescribes
a mapping $(i, j) \to k$, where $k$ is the index of the matrix
element in the output array. It focusses on the off-diagonal entries,
i.e. $i \neq j$. The subroutine [[blha_color_c_fill_offdiag]] realizes
this mapping. The diagonal entries can simply be obtained as
the product of the Born matrix element and either $C_A$ or $C_F$,
which is achieved by [[blha_color_c_fill_diag]].
For simple processes, i.e. those with only one color line, it is
$B_{ij} = C_F \cdot B$. For those, we keep the possibility of computing
color correlations by a multiplication of the Born matrix element with $C_F$.
It is triggered by the [[use_internal_color_correlations]] flag and should
be used only for testing purposes. However, it is also used for
the threshold computation where the process is well-defined and fixed.
<<Instances: term instance: TBP>>=
procedure :: evaluate_color_correlations => &
term_instance_evaluate_color_correlations
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_color_correlations (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
end subroutine term_instance_evaluate_color_correlations
<<Instances: procedures>>=
module subroutine term_instance_evaluate_color_correlations (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
integer :: i_flv_born
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
select type (pcm => term%pcm)
type is (pcm_nlo_t)
if (debug_on) call msg_debug2 (D_SUBTRACTION, &
"term_instance_evaluate_color_correlations: " // &
"use_internal_color_correlations:", &
pcm%settings%use_internal_color_correlations)
if (debug_on) call msg_debug2 (D_SUBTRACTION, "fac_scale", term%get_fac_scale ())
do i_flv_born = 1, pcm%region_data%n_flv_born
select case (term%nlo_type)
case (NLO_REAL)
call transfer_me_array_to_bij (pcm, i_flv_born, &
pcm_work%real_sub%sqme_born (i_flv_born), &
pcm_work%real_sub%sqme_born_color_c (:, :, i_flv_born))
case (NLO_MISMATCH)
call transfer_me_array_to_bij (pcm, i_flv_born, &
pcm_work%soft_mismatch%sqme_born (i_flv_born), &
pcm_work%soft_mismatch%sqme_born_color_c (:, :, i_flv_born))
case (NLO_VIRTUAL)
!!! This is just a copy of the above with a different offset and can for sure be unified
call transfer_me_array_to_bij (pcm, i_flv_born, &
-one, pcm_work%virtual%sqme_color_c (:, :, i_flv_born))
case (NLO_DGLAP)
call transfer_me_array_to_bij (pcm, i_flv_born, &
pcm_work%dglap_remnant%sqme_born (i_flv_born), &
pcm_work%dglap_remnant%sqme_color_c_extra (:, :, i_flv_born))
end select
end do
end select
end select
contains
function get_trivial_cf_factors (n_tot, flv, factorization_mode) result (beta_ij)
integer, intent(in) :: n_tot, factorization_mode
integer, intent(in), dimension(:) :: flv
real(default), dimension(n_tot, n_tot) :: beta_ij
if (factorization_mode == NO_FACTORIZATION) then
beta_ij = get_trivial_cf_factors_default (n_tot, flv)
else
beta_ij = get_trivial_cf_factors_threshold (n_tot, flv)
end if
end function get_trivial_cf_factors
function get_trivial_cf_factors_default (n_tot, flv) result (beta_ij)
integer, intent(in) :: n_tot
integer, intent(in), dimension(:) :: flv
real(default), dimension(n_tot, n_tot) :: beta_ij
integer :: i, j
beta_ij = zero
if (count (is_quark (flv)) == 2) then
do i = 1, n_tot
do j = 1, n_tot
if (is_quark(flv(i)) .and. is_quark(flv(j))) then
if (i == j) then
beta_ij(i,j)= -cf
else
beta_ij(i,j) = cf
end if
end if
end do
end do
end if
end function get_trivial_cf_factors_default
function get_trivial_cf_factors_threshold (n_tot, flv) result (beta_ij)
integer, intent(in) :: n_tot
integer, intent(in), dimension(:) :: flv
real(default), dimension(n_tot, n_tot) :: beta_ij
integer :: i
beta_ij = zero
do i = 1, 4
beta_ij(i,i) = -cf
end do
beta_ij(1,2) = cf; beta_ij(2,1) = cf
beta_ij(3,4) = cf; beta_ij(4,3) = cf
end function get_trivial_cf_factors_threshold
subroutine transfer_me_array_to_bij (pcm, i_flv, &
sqme_born, sqme_color_c)
type(pcm_nlo_t), intent(in) :: pcm
integer, intent(in) :: i_flv
real(default), intent(in) :: sqme_born
real(default), dimension(:,:), intent(inout) :: sqme_color_c
logical :: special_case_interferences
integer :: i_color_c, i_sub, n_offset, i_qn
real(default), dimension(:), allocatable :: sqme
real(default) :: sqme_born_c
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "transfer_me_array_to_bij")
if (pcm%settings%use_internal_color_correlations) then
!!! A negative value for sqme_born indicates that the Born matrix
!!! element is multiplied at a different place, e.g. in the case
!!! of the virtual component
sqme_color_c = get_trivial_cf_factors &
(pcm%region_data%get_n_legs_born (), &
pcm%region_data%get_flv_states_born (i_flv), &
pcm%settings%factorization_mode)
if (sqme_born > zero) then
sqme_color_c = sqme_born * sqme_color_c
else if (sqme_born == zero) then
sqme_color_c = zero
end if
else
special_case_interferences = &
pcm%region_data%nlo_correction_type == "EW"
n_offset = 0
if (term%nlo_type == NLO_VIRTUAL) then
n_offset = 1
else if (pcm%has_pdfs .and. (term%is_subtraction () &
.or. term%nlo_type == NLO_DGLAP)) then
n_offset = n_beams_rescaled
end if
allocate (sqme (term%get_n_sub_color ()), source = zero)
do i_sub = 1, term%get_n_sub_color ()
i_qn = term%connected%trace%get_qn_index (i_flv, i_sub = i_sub + n_offset)
if (term%passed_array(i_flv) .or. .not. term%passed) then
sqme(i_sub) = real(term%connected%trace%get_matrix_element (i_qn), default)
else
sqme(i_sub) = zero
end if
end do
call blha_color_c_fill_offdiag (pcm%region_data%n_legs_born, &
sqme, sqme_color_c)
i_qn = term%connected%trace%get_qn_index (i_flv, i_sub = 0)
if (term%passed_array(i_flv) .or. .not. term%passed) then
sqme_born_c = real(term%connected%trace%get_matrix_element (i_qn), default)
else
sqme_born_c = zero
end if
call blha_color_c_fill_diag (sqme_born_c, &
pcm%region_data%get_flv_states_born (i_flv), &
sqme_color_c, special_case_interferences)
end if
end subroutine transfer_me_array_to_bij
end subroutine term_instance_evaluate_color_correlations
@ %def term_instance_evaluate_color_correlations
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_charge_correlations => &
term_instance_evaluate_charge_correlations
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_charge_correlations (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
end subroutine term_instance_evaluate_charge_correlations
<<Instances: procedures>>=
module subroutine term_instance_evaluate_charge_correlations (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
integer :: i_flv_born
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
select type (pcm => term%pcm)
type is (pcm_nlo_t)
do i_flv_born = 1, pcm%region_data%n_flv_born
select case (term%nlo_type)
case (NLO_REAL)
call transfer_me_array_to_bij (pcm, i_flv_born, &
pcm_work%real_sub%sqme_born (i_flv_born), &
pcm_work%real_sub%sqme_born_charge_c (:, :, i_flv_born))
case (NLO_MISMATCH)
call transfer_me_array_to_bij (pcm, i_flv_born, &
pcm_work%soft_mismatch%sqme_born (i_flv_born), &
pcm_work%soft_mismatch%sqme_born_charge_c (:, :, i_flv_born))
case (NLO_VIRTUAL)
call transfer_me_array_to_bij (pcm, i_flv_born, &
one, pcm_work%virtual%sqme_charge_c (:, :, i_flv_born))
end select
end do
end select
end select
contains
subroutine transfer_me_array_to_bij (pcm, i_flv, sqme_born, sqme_charge_c)
type(pcm_nlo_t), intent(in) :: pcm
integer, intent(in) :: i_flv
real(default), intent(in) :: sqme_born
real(default), dimension(:,:), intent(inout) :: sqme_charge_c
integer :: n_legs_born, i, j
real(default), dimension(:), allocatable :: sigma
real(default), dimension(:), allocatable :: Q
n_legs_born = pcm%region_data%n_legs_born
associate (flv_born => pcm%region_data%flv_born(i_flv))
allocate (sigma (n_legs_born), Q (size (flv_born%charge)))
Q = flv_born%charge
sigma(1:flv_born%n_in) = -one
sigma(flv_born%n_in + 1: ) = one
end associate
do i = 1, n_legs_born
do j = 1, n_legs_born
sqme_charge_c(i, j) = sigma(i) * sigma(j) * Q(i) * Q(j) * (-one)
end do
end do
sqme_charge_c = sqme_charge_c * sqme_born
end subroutine transfer_me_array_to_bij
end subroutine term_instance_evaluate_charge_correlations
@ %def term_instance_evaluate_charge_correlations
@ The information about spin correlations is not stored in the
[[nlo_settings]] because it is only available after the
[[fks_regions]] have been created.
<<Instances: term instance: TBP>>=
procedure :: evaluate_spin_correlations => &
term_instance_evaluate_spin_correlations
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_spin_correlations (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
end subroutine term_instance_evaluate_spin_correlations
<<Instances: procedures>>=
module subroutine term_instance_evaluate_spin_correlations (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
integer :: i_flv, i_sub, i_emitter, emitter, i_qn
integer :: n_flv, n_sub_color, n_sub_spin, n_offset,i,j
real(default), dimension(1:3, 1:3) :: sqme_spin_c
real(default), dimension(:), allocatable :: sqme_spin_c_all
real(default), dimension(:), allocatable :: sqme_spin_c_arr
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
"term_instance_evaluate_spin_correlations")
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
if (pcm_work%real_sub%requires_spin_correlations () &
.and. term%nlo_type == NLO_REAL) then
select type (core)
type is (prc_openloops_t)
select type (pcm => term%pcm)
type is (pcm_nlo_t)
n_flv = term%connected%trace%get_qn_index_n_flv ()
n_sub_color = term%get_n_sub_color ()
n_sub_spin = term%get_n_sub_spin ()
n_offset = 0; if(pcm%has_pdfs) n_offset = n_beams_rescaled
allocate (sqme_spin_c_arr(6))
do i_flv = 1, n_flv
allocate (sqme_spin_c_all(n_sub_spin))
do i_sub = 1, n_sub_spin
i_qn = term%connected%trace%get_qn_index (i_flv, &
i_sub = i_sub + n_offset + n_sub_color)
if (term%passed_array(i_flv) .or. .not. term%passed) then
sqme_spin_c_all(i_sub) = &
real(term%connected%trace%get_matrix_element (i_qn), default)
else
sqme_spin_c_all(i_sub) = zero
end if
end do
do i_emitter = 1, pcm%region_data%n_emitters
emitter = pcm%region_data%emitters(i_emitter)
if (emitter > 0) then
call split_array (sqme_spin_c_all, sqme_spin_c_arr)
do j = 1, size (sqme_spin_c, dim=2)
do i = j, size (sqme_spin_c, dim=1)
!!! Restoring the symmetric matrix packed into a 1-dim array
!!! c.f. [[prc_openloops_compute_sqme_spin_c]]
sqme_spin_c(i,j) = sqme_spin_c_arr(j + i * (i - 1) / 2)
if (i /= j) sqme_spin_c(j,i) = sqme_spin_c(i,j)
end do
end do
pcm_work%real_sub%sqme_born_spin_c(:,:,emitter,i_flv) = sqme_spin_c
end if
end do
deallocate (sqme_spin_c_all)
end do
end select
class default
call msg_fatal &
("Spin correlations so far only supported by OpenLoops.")
end select
end if
end select
end subroutine term_instance_evaluate_spin_correlations
@ %def term_instance_evaluate_spin_correlations
@
<<Instances: term instance: TBP>>=
procedure :: apply_fks => term_instance_apply_fks
<<Instances: sub interfaces>>=
module subroutine term_instance_apply_fks &
(term, kin, alpha_s_sub, alpha_qed_sub)
class(term_instance_t), intent(inout) :: term
class(kinematics_t), intent(inout) :: kin
real(default), intent(in) :: alpha_s_sub, alpha_qed_sub
end subroutine term_instance_apply_fks
<<Instances: procedures>>=
module subroutine term_instance_apply_fks &
(term, kin, alpha_s_sub, alpha_qed_sub)
class(term_instance_t), intent(inout) :: term
class(kinematics_t), intent(inout) :: kin
real(default), intent(in) :: alpha_s_sub, alpha_qed_sub
real(default), dimension(:), allocatable :: sqme
integer :: i, i_phs, emitter, i_qn
logical :: is_subtraction
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
select type (pcm => term%pcm)
type is (pcm_nlo_t)
if (term%connected%has_matrix) then
allocate (sqme (pcm%get_n_alr ()))
else
allocate (sqme (1))
end if
sqme = zero
select type (phs => kin%phs)
type is (phs_fks_t)
if (pcm%has_pdfs .and. &
pcm%settings%use_internal_color_correlations) then
call msg_fatal ("Color correlations for proton processes " // &
"so far only supported by OpenLoops.")
end if
call pcm_work%set_real_and_isr_kinematics &
(phs%phs_identifiers, kin%phs%get_sqrts ())
if (kin%emitter < 0) then
call pcm_work%set_subtraction_event ()
do i_phs = 1, pcm%region_data%n_phs
emitter = phs%phs_identifiers(i_phs)%emitter
call pcm_work%real_sub%compute (emitter, &
i_phs, alpha_s_sub, alpha_qed_sub, term%connected%has_matrix, sqme)
end do
else
call pcm_work%set_radiation_event ()
emitter = kin%emitter; i_phs = kin%i_phs
do i = 1, term%connected%trace%get_qn_index_n_flv ()
i_qn = term%connected%trace%get_qn_index (i)
if (term%passed_array(i) .or. .not. term%passed) then
pcm_work%real_sub%sqme_real_non_sub (i, i_phs) = &
real (term%connected%trace%get_matrix_element (i_qn))
else
pcm_work%real_sub%sqme_real_non_sub (i, i_phs) = zero
end if
end do
call pcm_work%real_sub%compute (emitter, i_phs, alpha_s_sub, &
alpha_qed_sub, term%connected%has_matrix, sqme)
end if
end select
end select
end select
if (term%connected%has_trace) &
call term%connected%trace%set_only_matrix_element &
(1, cmplx (sum(sqme), 0, default))
select type (pcm => term%pcm)
type is (pcm_nlo_t)
is_subtraction = kin%emitter < 0
if (term%connected%has_matrix) &
call refill_evaluator (cmplx (sqme * term%weight, 0, default), &
pcm%get_qn (is_subtraction), &
pcm%region_data%get_flavor_indices (is_subtraction), &
term%connected%matrix)
if (term%connected%has_flows) &
call refill_evaluator (cmplx (sqme * term%weight, 0, default), &
pcm%get_qn (is_subtraction), &
pcm%region_data%get_flavor_indices (is_subtraction), &
term%connected%flows)
end select
end subroutine term_instance_apply_fks
@ %def term_instance_apply_fks
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_sqme_virt => term_instance_evaluate_sqme_virt
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_sqme_virt &
(term, alpha_s, alpha_qed)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_s, alpha_qed
end subroutine term_instance_evaluate_sqme_virt
<<Instances: procedures>>=
module subroutine term_instance_evaluate_sqme_virt (term, alpha_s, alpha_qed)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_s, alpha_qed
real(default), dimension(2) :: alpha_coupling
type(vector4_t), dimension(:), allocatable :: p_born
real(default), dimension(:), allocatable :: sqme_virt
integer :: i_flv, i_qn_born, i_qn_virt
if (term%nlo_type /= NLO_VIRTUAL) call msg_fatal ("Trying to " // &
"evaluate virtual matrix element with unsuited term_instance.")
if (debug2_active (D_VIRTUAL)) then
call msg_debug2 &
(D_VIRTUAL, "Evaluating virtual-subtracted matrix elements")
print *, 'ren_scale: ', term%get_ren_scale ()
print *, 'fac_scale: ', term%get_fac_scale ()
if (allocated (term%es_scale)) then
print *, 'ES scale: ', term%es_scale
else
print *, 'ES scale: ', term%get_ren_scale ()
end if
end if
select type (pcm => term%pcm)
type is (pcm_nlo_t)
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
alpha_coupling = [alpha_s, alpha_qed]
if (debug2_active (D_VIRTUAL)) then
print *, 'alpha_s: ', alpha_coupling (1)
print *, 'alpha_qed: ', alpha_coupling (2)
end if
allocate (p_born (pcm%region_data%n_legs_born))
if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
p_born = pcm_work%real_kinematics%p_born_onshell%get_momenta(1)
else
p_born = term%int_hard%get_momenta ()
end if
call pcm_work%set_momenta_and_scales_virtual &
(p_born, term%ren_scale, term%get_fac_scale (), &
term%es_scale)
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
associate (virtual => pcm_work%virtual)
do i_flv = 1, term%connected%trace%get_qn_index_n_flv ()
i_qn_born = term%connected%trace%get_qn_index (i_flv, i_sub = 0)
i_qn_virt = term%connected%trace%get_qn_index (i_flv, i_sub = 1)
if (term%passed_array(i_flv) .or. .not. term%passed) then
virtual%sqme_born(i_flv) = &
real (term%connected%trace%get_matrix_element (i_qn_born))
virtual%sqme_virt_fin(i_flv) = &
real (term%connected%trace%get_matrix_element (i_qn_virt))
else
virtual%sqme_born(i_flv) = zero
virtual%sqme_virt_fin(i_flv) = zero
end if
end do
end associate
end select
call pcm_work%compute_sqme_virt (term%pcm, term%p_hard, &
alpha_coupling, term%connected%has_matrix, sqme_virt)
call term%connected%trace%set_only_matrix_element &
(1, cmplx (sum(sqme_virt), 0, default))
if (term%connected%has_matrix) &
call refill_evaluator (cmplx (sqme_virt * term%weight, &
0, default), pcm%get_qn (.true.), &
remove_duplicates_from_int_array ( &
pcm%region_data%get_flavor_indices (.true.)), &
term%connected%matrix)
if (term%connected%has_flows) &
call refill_evaluator (cmplx (sqme_virt * term%weight, &
0, default), pcm%get_qn (.true.), &
remove_duplicates_from_int_array ( &
pcm%region_data%get_flavor_indices (.true.)), &
term%connected%flows)
end select
end select
end subroutine term_instance_evaluate_sqme_virt
@ %def term_instance_evaluate_sqme_virt
@ Needs generalization to electroweak corrections.
<<Instances: term instance: TBP>>=
procedure :: evaluate_sqme_mismatch => term_instance_evaluate_sqme_mismatch
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_sqme_mismatch (term, alpha_s)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_s
end subroutine term_instance_evaluate_sqme_mismatch
<<Instances: procedures>>=
module subroutine term_instance_evaluate_sqme_mismatch (term, alpha_s)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_s
real(default), dimension(:), allocatable :: sqme_mism
if (term%nlo_type /= NLO_MISMATCH) call msg_fatal &
("Trying to evaluate soft mismatch with unsuited term_instance.")
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
call pcm_work%compute_sqme_mismatch &
(term%pcm, alpha_s, term%connected%has_matrix, sqme_mism)
end select
call term%connected%trace%set_only_matrix_element &
(1, cmplx (sum (sqme_mism) * term%weight, 0, default))
if (term%connected%has_matrix) then
select type (pcm => term%pcm)
type is (pcm_nlo_t)
if (term%connected%has_matrix) &
call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), &
pcm%get_qn (.true.), &
remove_duplicates_from_int_array ( &
pcm%region_data%get_flavor_indices (.true.)), &
term%connected%matrix)
if (term%connected%has_flows) &
call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), &
pcm%get_qn (.true.), &
remove_duplicates_from_int_array ( &
pcm%region_data%get_flavor_indices (.true.)), &
term%connected%flows)
end select
end if
end subroutine term_instance_evaluate_sqme_mismatch
@ %def term_instance_evaluate_sqme_mismatch
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_sqme_dglap => term_instance_evaluate_sqme_dglap
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_sqme_dglap &
(term, alpha_s, alpha_qed)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_s, alpha_qed
end subroutine term_instance_evaluate_sqme_dglap
<<Instances: procedures>>=
module subroutine term_instance_evaluate_sqme_dglap (term, alpha_s, alpha_qed)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_s, alpha_qed
real(default), dimension(2) :: alpha_coupling
real(default), dimension(:), allocatable :: sqme_dglap
integer :: i_flv
if (term%nlo_type /= NLO_DGLAP) call msg_fatal &
("Trying to evaluate DGLAP remnant with unsuited term_instance.")
if (debug_on) call msg_debug2 &
(D_PROCESS_INTEGRATION, "term_instance_evaluate_sqme_dglap")
select type (pcm => term%pcm)
type is (pcm_nlo_t)
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
alpha_coupling = [alpha_s,alpha_qed]
if (debug2_active (D_PROCESS_INTEGRATION)) then
associate (n_flv => pcm_work%dglap_remnant%reg_data%n_flv_born)
print *, "size(sqme_born) = ", &
size (pcm_work%dglap_remnant%sqme_born)
call term%connected%trace%write ()
end associate
end if
call pcm_work%compute_sqme_dglap_remnant (pcm, alpha_coupling, &
term%connected%has_matrix, sqme_dglap)
end select
end select
call term%connected%trace%set_only_matrix_element &
(1, cmplx (sum (sqme_dglap) * term%weight, 0, default))
if (term%connected%has_matrix) then
select type (pcm => term%pcm)
type is (pcm_nlo_t)
call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), &
pcm%get_qn (.true.), &
remove_duplicates_from_int_array ( &
pcm%region_data%get_flavor_indices (.true.)), &
term%connected%matrix)
if (term%connected%has_flows) then
call refill_evaluator &
(cmplx (sqme_dglap * term%weight, 0, default), &
pcm%get_qn (.true.), &
remove_duplicates_from_int_array ( &
pcm%region_data%get_flavor_indices (.true.)), &
term%connected%flows)
end if
end select
end if
end subroutine term_instance_evaluate_sqme_dglap
@ %def term_instance_evaluate_sqme_dglap
@ Reset the term instance: clear the parton-state expressions and deactivate.
<<Instances: term instance: TBP>>=
procedure :: reset => term_instance_reset
<<Instances: sub interfaces>>=
module subroutine term_instance_reset (term)
class(term_instance_t), intent(inout) :: term
end subroutine term_instance_reset
<<Instances: procedures>>=
module subroutine term_instance_reset (term)
class(term_instance_t), intent(inout) :: term
call term%connected%reset_expressions ()
if (allocated (term%alpha_qcd_forced)) deallocate (term%alpha_qcd_forced)
term%active = .false.
end subroutine term_instance_reset
@ %def term_instance_reset
@ Force an $\alpha_s$ value that should be used in the matrix-element
calculation.
<<Instances: term instance: TBP>>=
procedure :: set_alpha_qcd_forced => term_instance_set_alpha_qcd_forced
<<Instances: sub interfaces>>=
module subroutine term_instance_set_alpha_qcd_forced (term, alpha_qcd)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_qcd
end subroutine term_instance_set_alpha_qcd_forced
<<Instances: procedures>>=
module subroutine term_instance_set_alpha_qcd_forced (term, alpha_qcd)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_qcd
if (allocated (term%alpha_qcd_forced)) then
term%alpha_qcd_forced = alpha_qcd
else
allocate (term%alpha_qcd_forced, source = alpha_qcd)
end if
end subroutine term_instance_set_alpha_qcd_forced
@ %def term_instance_set_alpha_qcd_forced
@ Complete the kinematics computation for the effective parton states.
We assume that the [[compute_hard_kinematics]] method of the process
component instance has already been called, so the [[int_hard]]
contains the correct hard kinematics. The duty of this procedure is
first to compute the effective kinematics and store this in the
[[int_eff]] effective interaction inside the [[isolated]] parton
state. The effective kinematics may differ from the kinematics in the hard
interaction. It may involve parton recombination or parton splitting.
The [[rearrange_partons]] method is responsible for this part.
We may also call a method to compute the effective structure-function
chain at this point. This is not implemented yet.
In the simple case that no rearrangement is necessary, as indicated by
the [[rearrange]] flag, the effective interaction is a pointer to the
hard interaction, and we can skip the rearrangement method. Similarly
for the effective structure-function chain.
The final step of kinematics setup is to transfer the effective
kinematics to the evaluators and to the [[subevt]].
<<Instances: term instance: TBP>>=
procedure :: compute_eff_kinematics => &
term_instance_compute_eff_kinematics
<<Instances: sub interfaces>>=
module subroutine term_instance_compute_eff_kinematics (term)
class(term_instance_t), intent(inout) :: term
end subroutine term_instance_compute_eff_kinematics
<<Instances: procedures>>=
module subroutine term_instance_compute_eff_kinematics (term)
class(term_instance_t), intent(inout) :: term
term%checked = .false.
term%passed = .false.
call term%isolated%receive_kinematics ()
call term%connected%receive_kinematics ()
end subroutine term_instance_compute_eff_kinematics
@ %def term_instance_compute_eff_kinematics
@ Inverse. Reconstruct the connected state from the momenta in the
trace evaluator (which we assume to be set), then reconstruct the
isolated state as far as possible. The second part finalizes the
momentum configuration, using the incoming seed momenta
<<Instances: term instance: TBP>>=
procedure :: recover_hard_kinematics => &
term_instance_recover_hard_kinematics
<<Instances: sub interfaces>>=
module subroutine term_instance_recover_hard_kinematics (term)
class(term_instance_t), intent(inout) :: term
end subroutine term_instance_recover_hard_kinematics
<<Instances: procedures>>=
module subroutine term_instance_recover_hard_kinematics (term)
class(term_instance_t), intent(inout) :: term
term%checked = .false.
term%passed = .false.
call term%connected%send_kinematics ()
call term%isolated%send_kinematics ()
end subroutine term_instance_recover_hard_kinematics
@ %def term_instance_recover_hard_kinematics
@ Check the term whether it passes cuts and, if successful, evaluate
scales and weights. The factorization scale is also given to the term
kinematics, enabling structure-function evaluation.
<<Instances: term instance: TBP>>=
procedure :: evaluate_expressions => &
term_instance_evaluate_expressions
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_expressions &
(term, config, scale_forced)
class(term_instance_t), intent(inout) :: term
type(process_beam_config_t), intent(in) :: config
real(default), intent(in), allocatable, optional :: scale_forced
end subroutine term_instance_evaluate_expressions
<<Instances: procedures>>=
module subroutine term_instance_evaluate_expressions &
(term, config, scale_forced)
class(term_instance_t), intent(inout) :: term
type(process_beam_config_t), intent(in) :: config
real(default), intent(in), allocatable, optional :: scale_forced
real(default) :: scale = 0
real(default) :: weight = 1
real(default), allocatable :: fac_scale, ren_scale
type(interaction_t), pointer :: src_int
type(state_matrix_t), pointer :: state_matrix
type(flavor_t), dimension(:), allocatable :: flv_int, flv_src, f_in, f_out
logical :: passed
integer :: n_in, n_vir, n_out, n_tot, n_flv
integer :: i, j, k
n_flv = term%connected%trace%get_qn_index_n_flv ()
if (.not. allocated (term%passed_array)) allocate (term%passed_array(n_flv))
if (term%flv_dep_cut_eval) then
do k = 1, n_flv
if (k == term%i_flv_to_i_flv_rep(k)) then
n_in = term%int_hard%get_n_in ()
associate (int_eff => term%isolated%int_eff)
state_matrix => int_eff%get_state_matrix_ptr ()
n_tot = int_eff%get_n_tot ()
flv_int = quantum_numbers_get_flavor &
(state_matrix%get_quantum_number (k))
allocate (f_in (n_in))
f_in = flv_int(1:n_in)
deallocate (flv_int)
end associate
n_in = term%connected%trace%get_n_in ()
n_vir = term%connected%trace%get_n_vir ()
n_out = term%connected%trace%get_n_out ()
allocate (f_out (n_out))
do j = 1, n_out
call term%connected%trace%find_source &
(n_in + n_vir + j, src_int, i)
if (associated (src_int)) then
state_matrix => src_int%get_state_matrix_ptr ()
flv_src = quantum_numbers_get_flavor &
(state_matrix%get_quantum_number (k))
f_out(j) = flv_src(i)
deallocate (flv_src)
end if
end do
call term%connected%renew_flv_content_subevt &
(term%isolated%sf_chain_eff, &
config%data%flv, f_in, f_out)
call term%connected%evaluate_expressions (passed, &
scale, fac_scale, ren_scale, weight, &
scale_forced, force_evaluation = .true.)
if (k == 1) then
term%scale = scale
if (allocated (fac_scale)) then
if (.not. allocated (term%fac_scale)) then
allocate (term%fac_scale, source = fac_scale)
else
term%fac_scale = fac_scale
end if
end if
if (allocated (ren_scale)) then
if (.not. allocated (term%ren_scale)) then
allocate (term%ren_scale, source = ren_scale)
else
term%ren_scale = ren_scale
end if
end if
term%weight = weight
end if
term%passed_array(k) = passed
deallocate (f_in)
deallocate (f_out)
else
term%passed_array(k) = term%passed_array(term%i_flv_to_i_flv_rep(k))
end if
end do
term%passed = any (term%passed_array)
else
call term%connected%evaluate_expressions (term%passed, &
term%scale, term%fac_scale, term%ren_scale, term%weight, &
scale_forced, force_evaluation = .true.)
term%passed_array = term%passed
end if
term%checked = .true.
end subroutine term_instance_evaluate_expressions
@ %def term_instance_evaluate_expressions
@ Evaluate the trace: first evaluate the hard interaction, then the trace
evaluator. We use the [[evaluate_interaction]] method of the process
component which generated this term. The [[subevt]] and cut expressions are
not yet filled.
The [[component]] argument is intent(inout) because the [[compute_amplitude]]
method may modify the [[core_state]] workspace object.
<<Instances: term instance: TBP>>=
procedure :: evaluate_interaction => term_instance_evaluate_interaction
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_interaction (term, core, kin)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(in), pointer :: core
type(kinematics_t), intent(inout) :: kin
end subroutine term_instance_evaluate_interaction
<<Instances: procedures>>=
module subroutine term_instance_evaluate_interaction (term, core, kin)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(in), pointer :: core
type(kinematics_t), intent(inout) :: kin
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
"term_instance_evaluate_interaction")
if (kin%only_cm_frame .and. (.not. kin%lab_is_cm())) then
term%p_hard = kin%get_boost_to_cms () * term%int_hard%get_momenta ()
else
term%p_hard = term%int_hard%get_momenta ()
end if
select type (core)
class is (prc_external_t)
call term%evaluate_interaction_external (core, kin)
class default
call term%evaluate_interaction_default (core)
end select
call term%int_hard%set_matrix_element (term%amp)
end subroutine term_instance_evaluate_interaction
@ %def term_instance_evaluate_interaction
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_interaction_default &
=> term_instance_evaluate_interaction_default
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_interaction_default (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(in) :: core
end subroutine term_instance_evaluate_interaction_default
<<Instances: procedures>>=
module subroutine term_instance_evaluate_interaction_default (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(in) :: core
real(default) :: fac_scale, ren_scale
integer :: i
if (allocated (term%fac_scale)) then
fac_scale = term%fac_scale
else
fac_scale = term%scale
end if
if (allocated (term%ren_scale)) then
ren_scale = term%ren_scale
else
ren_scale = term%scale
end if
do i = 1, term%config%n_allowed
term%amp(i) = core%compute_amplitude (term%config%i_term, term%p_hard, &
term%config%flv(i), term%config%hel(i), term%config%col(i), &
fac_scale, ren_scale, term%alpha_qcd_forced, &
term%core_state)
end do
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
call pcm_work%set_fac_scale (fac_scale)
end select
end subroutine term_instance_evaluate_interaction_default
@ %def term_instance_evaluate_interaction_default
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_interaction_external &
=> term_instance_evaluate_interaction_external
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_interaction_external &
(term, core, kin)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
type(kinematics_t), intent(inout) :: kin
end subroutine term_instance_evaluate_interaction_external
<<Instances: procedures>>=
module subroutine term_instance_evaluate_interaction_external &
(term, core, kin)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
type(kinematics_t), intent(inout) :: kin
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
"term_instance_evaluate_interaction_external")
select type (core_state => term%core_state)
type is (openloops_state_t)
select type (core)
type is (prc_openloops_t)
call core%compute_alpha_s (core_state, term%get_ren_scale ())
if (allocated (core_state%threshold_data)) &
call evaluate_threshold_parameters (core_state, core, kin%phs%get_sqrts ())
end select
class is (prc_external_state_t)
select type (core)
class is (prc_external_t)
call core%compute_alpha_s (core_state, term%get_ren_scale ())
end select
end select
call evaluate_threshold_interaction ()
if (term%nlo_type == NLO_VIRTUAL) then
call term%evaluate_interaction_external_loop (core)
else
call term%evaluate_interaction_external_tree (core)
end if
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
call pcm_work%set_fac_scale (term%get_fac_scale ())
end select
contains
subroutine evaluate_threshold_parameters (core_state, core, sqrts)
type(openloops_state_t), intent(inout) :: core_state
type(prc_openloops_t), intent(inout) :: core
real(default), intent(in) :: sqrts
real(default) :: mtop, wtop
mtop = m1s_to_mpole (sqrts)
wtop = core_state%threshold_data%compute_top_width &
(mtop, core_state%alpha_qcd)
call core%set_mass_and_width (6, mtop, wtop)
end subroutine
subroutine evaluate_threshold_interaction ()
integer :: leg
select type (core)
type is (prc_threshold_t)
if (term%nlo_type > BORN) then
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
if (kin%emitter >= 0) then
call core%set_offshell_momenta &
(pcm_work%real_kinematics%p_real_cms%get_momenta(term%config%i_term))
leg = thr_leg (kin%emitter)
call core%set_leg (leg)
call core%set_onshell_momenta &
(pcm_work%real_kinematics%p_real_onshell(leg)%get_momenta(term%config%i_term))
else
call core%set_leg (0)
call core%set_offshell_momenta &
(pcm_work%real_kinematics%p_born_cms%get_momenta(1))
end if
end select
else
call core%set_leg (-1)
call core%set_offshell_momenta (term%p_hard)
end if
end select
end subroutine evaluate_threshold_interaction
end subroutine term_instance_evaluate_interaction_external
@ %def term_instance_evaluate_interaction_external
@ Retrieve the matrix elements from a matrix element provider and place them
into [[term%amp]].
For the handling of NLO calculations, FKS applies a book keeping handling
flavor and/or particle type (e.g. for QCD: quark/gluon and quark flavor) in
order to calculate the subtraction terms. Therefore, we have to insert the
calculated matrix elements correctly into the state matrix where each entry
corresponds to a set of quantum numbers. We apply a mapping
[[hard_qn_ind]] from a list of quantum numbers provided by FKS to the
hard process [[int_hard]].
The calculated matrix elements are insert into [[term%amp]] in the following
way. The first [[n_born]] particles are the matrix element of the hard process.
In non-trivial beams, we store another [[n_beams_rescaled]] copies of these
matrix elements as the first [[n_beams_rescaled]] subtractions. This
is a remnant from times before the method
[[term_instance_set_sf_factors]] and these entries are not used
anymore. However, eliminating these entries involves deeper changes in
how the connection tables for the evaluator product are set up and
should therefore be part of a larger refactoring of the interactions
\& state matrices. The next $n_{\text{born}}\times n_{sub_color}$ are
color-correlated Born matrix elements, with then again the next
$n_{\text{born}}\times n_{emitters}\times n_{sub_spin}$ being
spin-correlated Born matrix elements.
If two or more flavor structures would produce the same amplitude we
only compute one and use the [[eqv_index]] determined by the
[[prc_core]] and just copy the result to improve performance.
<<Instances: term instance: TBP>>=
procedure :: evaluate_interaction_external_tree &
=> term_instance_evaluate_interaction_external_tree
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_interaction_external_tree &
(term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
end subroutine term_instance_evaluate_interaction_external_tree
<<Instances: procedures>>=
module subroutine term_instance_evaluate_interaction_external_tree &
(term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
real(default) :: sqme
real(default), dimension(:), allocatable :: sqme_color_c
real(default), dimension(:), allocatable :: sqme_spin_c
real(default), dimension(6) :: sqme_spin_c_tmp
integer :: n_flv, n_hel, n_sub_color, n_sub_spin, n_pdf_off
integer :: i_flv, i_hel, i_sub, i_color_c, i_color_c_eqv, &
i_spin_c, i_spin_c_eqv
integer :: i_flv_eqv, i_hel_eqv
integer :: emitter, i_emitter
logical :: bad_point, bp
logical, dimension(:,:), allocatable :: eqv_me_evaluated
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
"term_instance_evaluate_interaction_external_tree")
allocate (sqme_color_c (blha_result_array_size &
(term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C)))
n_flv = term%int_hard%get_qn_index_n_flv ()
n_hel = term%int_hard%get_qn_index_n_hel ()
n_sub_color = term%get_n_sub_color ()
n_sub_spin = term%get_n_sub_spin ()
allocate (eqv_me_evaluated(n_flv,n_hel))
eqv_me_evaluated = .false.
do i_flv = 1, n_flv
if (.not. term%passed_array(i_flv) .and. term%passed) cycle
do i_hel = 1, n_hel
i_flv_eqv = core%data%eqv_flv_index(i_flv)
i_hel_eqv = core%data%eqv_hel_index(i_hel)
if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then
select type (core)
class is (prc_external_t)
call core%update_alpha_s (term%core_state, term%get_ren_scale ())
call core%compute_sqme (i_flv, i_hel, term%p_hard, &
term%get_ren_scale (), sqme, bad_point)
call term%pcm_work%set_bad_point (bad_point)
associate (i_int => term%int_hard%get_qn_index &
(i_flv = i_flv, i_hel = i_hel, i_sub = 0))
term%amp(i_int) = cmplx (sqme, 0, default)
end associate
end select
n_pdf_off = 0
if (term%pcm%has_pdfs .and. &
(term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then
n_pdf_off = n_pdf_off + n_beams_rescaled
do i_sub = 1, n_pdf_off
term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = &
term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0))
end do
end if
if (term%pcm%has_pdfs .and. term%nlo_type == NLO_DGLAP) then
sqme_color_c = zero
select type (pcm => term%pcm)
type is (pcm_nlo_t)
if (pcm%settings%nlo_correction_type == "EW" .and. &
pcm%region_data%alphas_power > 0) then
select type (core)
class is (prc_blha_t)
call core%compute_sqme_color_c_raw (i_flv, i_hel, &
term%p_hard, term%get_ren_scale (), sqme_color_c, &
bad_point)
call term%pcm_work%set_bad_point (bad_point)
class is (prc_recola_t)
call core%compute_sqme_color_c_raw (i_flv, i_hel, &
term%p_hard, term%get_ren_scale (), sqme_color_c, &
bad_point)
call term%pcm_work%set_bad_point (bad_point)
end select
end if
end select
do i_sub = 1, n_sub_color
i_color_c = term%int_hard%get_qn_index &
(i_flv, i_hel, i_sub + n_pdf_off)
term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default)
end do
end if
if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. &
term%nlo_type == NLO_MISMATCH) then
sqme_color_c = zero
select type (core)
class is (prc_blha_t)
call core%compute_sqme_color_c_raw (i_flv, i_hel, &
term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point)
call term%pcm_work%set_bad_point (bad_point)
class is (prc_recola_t)
call core%compute_sqme_color_c_raw (i_flv, i_hel, &
term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point)
call term%pcm_work%set_bad_point (bad_point)
end select
do i_sub = 1, n_sub_color
i_color_c = term%int_hard%get_qn_index &
(i_flv, i_hel, i_sub + n_pdf_off)
term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default)
end do
if (n_sub_spin > 0) then
bad_point = .false.
allocate (sqme_spin_c(0))
select type (core)
type is (prc_openloops_t)
select type (pcm => term%pcm)
type is (pcm_nlo_t)
do i_emitter = 1, pcm%region_data%n_emitters
emitter = pcm%region_data%emitters(i_emitter)
if (emitter > 0) then
call core%compute_sqme_spin_c &
(i_flv, &
i_hel, &
emitter, &
term%p_hard, &
term%get_ren_scale (), &
sqme_spin_c_tmp, &
bp)
sqme_spin_c = [sqme_spin_c, sqme_spin_c_tmp]
bad_point = bad_point .or. bp
end if
end do
end select
do i_sub = 1, n_sub_spin
i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, &
i_sub + n_pdf_off + n_sub_color)
term%amp(i_spin_c) = cmplx &
(sqme_spin_c(i_sub), 0, default)
end do
end select
deallocate (sqme_spin_c)
end if
end if
eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true.
else
associate (i_int => term%int_hard%get_qn_index &
(i_flv = i_flv, i_hel = i_hel, i_sub = 0), &
i_int_eqv => term%int_hard%get_qn_index &
(i_flv = i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0))
term%amp(i_int) = term%amp(i_int_eqv)
end associate
n_pdf_off = 0
if (term%pcm%has_pdfs .and. &
(term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then
n_pdf_off = n_pdf_off + n_beams_rescaled
do i_sub = 1, n_pdf_off
term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = &
term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0))
end do
end if
if (term%pcm%has_pdfs .and. term%nlo_type == NLO_DGLAP) then
do i_sub = 1, n_sub_color
i_color_c = term%int_hard%get_qn_index &
(i_flv, i_hel, i_sub + n_pdf_off)
i_color_c_eqv = term%int_hard%get_qn_index &
(i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off)
term%amp(i_color_c) = term%amp(i_color_c_eqv)
end do
end if
if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. &
term%nlo_type == NLO_MISMATCH) then
do i_sub = 1, n_sub_color
i_color_c = term%int_hard%get_qn_index &
(i_flv, i_hel, i_sub + n_pdf_off)
i_color_c_eqv = term%int_hard%get_qn_index &
(i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off)
term%amp(i_color_c) = term%amp(i_color_c_eqv)
end do
do i_sub = 1, n_sub_spin
i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, &
i_sub + n_pdf_off + n_sub_color)
i_spin_c_eqv = term%int_hard%get_qn_index (i_flv_eqv, i_hel_eqv, &
i_sub + n_pdf_off + n_sub_color)
term%amp(i_spin_c) = term%amp(i_spin_c_eqv)
end do
end if
end if
end do
end do
end subroutine term_instance_evaluate_interaction_external_tree
@ %def term_instance_evaluate_interaction_external_tree
@ Same as for [[term_instance_evaluate_interaction_external_tree]], but
for the integrated-subtraction and finite one-loop terms. We only need
color-correlated Born matrix elements, but an additional entry per
flavor structure for the finite one-loop contribution. We thus have
$2+n_{sub_color}$ entries in the [[term%amp]] for each [[i_flv]] and
[[i_hel]] combination.
If two or more flavor structures would produce the same amplitude we
only compute one and use the [[eqv_index]] determined by the
[[prc_core]] and just copy the result to improve performance.
<<Instances: term instance: TBP>>=
procedure :: evaluate_interaction_external_loop &
=> term_instance_evaluate_interaction_external_loop
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_interaction_external_loop &
(term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(in) :: core
end subroutine term_instance_evaluate_interaction_external_loop
<<Instances: procedures>>=
module subroutine term_instance_evaluate_interaction_external_loop &
(term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(in) :: core
integer :: n_hel, n_sub, n_flv
integer :: i, i_flv, i_hel, i_sub, i_virt, i_color_c, i_color_c_eqv
integer :: i_flv_eqv, i_hel_eqv
real(default), dimension(4) :: sqme_virt
real(default), dimension(:), allocatable :: sqme_color_c
real(default) :: es_scale
logical :: bad_point
logical, dimension(:,:), allocatable :: eqv_me_evaluated
if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
"term_instance_evaluate_interaction_external_loop")
allocate (sqme_color_c (blha_result_array_size &
(term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C)))
n_flv = term%int_hard%get_qn_index_n_flv ()
n_hel = term%int_hard%get_qn_index_n_hel ()
n_sub = term%int_hard%get_qn_index_n_sub ()
allocate (eqv_me_evaluated(n_flv,n_hel))
eqv_me_evaluated = .false.
i_virt = 1
do i_flv = 1, n_flv
if (.not. term%passed_array(i_flv) .and. term%passed) cycle
do i_hel = 1, n_hel
i_flv_eqv = core%data%eqv_flv_index(i_flv)
i_hel_eqv = core%data%eqv_hel_index(i_hel)
if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then
select type (core)
class is (prc_external_t)
if (allocated (term%es_scale)) then
es_scale = term%es_scale
else
es_scale = term%get_ren_scale ()
end if
call core%compute_sqme_virt (i_flv, i_hel, term%p_hard, &
term%get_ren_scale (), es_scale, &
term%pcm%blha_defaults%loop_method, &
sqme_virt, bad_point)
call term%pcm_work%set_bad_point (bad_point)
end select
associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), &
i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt))
term%amp(i_loop) = cmplx (sqme_virt(3), 0, default)
term%amp(i_born) = cmplx (sqme_virt(4), 0, default)
end associate
select type (pcm => term%pcm)
type is (pcm_nlo_t)
select type (core)
class is (prc_blha_t)
call core%compute_sqme_color_c_raw (i_flv, i_hel, &
term%p_hard, term%get_ren_scale (), &
sqme_color_c, bad_point)
call term%pcm_work%set_bad_point (bad_point)
do i_sub = 1 + i_virt, n_sub
i_color_c = term%int_hard%get_qn_index &
(i_flv, i_hel = i_hel, i_sub = i_sub)
! Index shift: i_sub - i_virt
term%amp(i_color_c) = &
cmplx (sqme_color_c(i_sub - i_virt), 0, default)
end do
type is (prc_recola_t)
call core%compute_sqme_color_c_raw (i_flv, i_hel, &
term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point)
call term%pcm_work%set_bad_point (bad_point)
do i_sub = 1 + i_virt, n_sub
i_color_c = term%int_hard%get_qn_index &
(i_flv, i_hel = i_hel, i_sub = i_sub)
! Index shift: i_sub - i_virt
term%amp(i_color_c) = &
cmplx (sqme_color_c(i_sub - i_virt), 0, default)
end do
end select
end select
eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true.
else
associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), &
i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt), &
i_born_eqv => term%int_hard%get_qn_index &
(i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0), &
i_loop_eqv => term%int_hard%get_qn_index &
(i_flv_eqv, i_hel = i_hel_eqv, i_sub = 1))
term%amp(i_loop) = term%amp(i_loop_eqv)
term%amp(i_born) = term%amp(i_born_eqv)
end associate
do i_sub = 1 + i_virt, n_sub
i_color_c = term%int_hard%get_qn_index &
(i_flv, i_hel = i_hel, i_sub = i_sub)
i_color_c_eqv = term%int_hard%get_qn_index &
(i_flv_eqv, i_hel = i_hel_eqv, i_sub = i_sub)
! Index shift: i_sub - i_virt
term%amp(i_color_c) = term%amp(i_color_c_eqv)
end do
end if
end do
end do
end subroutine term_instance_evaluate_interaction_external_loop
@ %def term_instance_evaluate_interaction_external_loop
@ Evaluate the trace. First evaluate the
structure-function chain (i.e., the density matrix of the incoming
partons). Do this twice, in case the sf-chain instances within
[[kin]] and [[isolated]] differ. Next, evaluate the hard
interaction, then compute the convolution with the initial state.
<<Instances: term instance: TBP>>=
procedure :: evaluate_trace => term_instance_evaluate_trace
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_trace (term, kin)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(inout) :: kin
end subroutine term_instance_evaluate_trace
<<Instances: procedures>>=
module subroutine term_instance_evaluate_trace (term, kin)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(inout) :: kin
real(default) :: fac_scale
if (allocated (term%fac_scale)) then
fac_scale = term%fac_scale
else
fac_scale = term%scale
end if
call kin%evaluate_sf_chain (fac_scale, term%negative_sf)
call term%evaluate_scaled_sf_chains (kin)
call term%isolated%evaluate_sf_chain (fac_scale)
call term%isolated%evaluate_trace ()
call term%connected%evaluate_trace ()
end subroutine term_instance_evaluate_trace
@ %def term_instance_evaluate_trace
@ Include rescaled structure functions due to NLO calculation. We
rescale the structure function for the real subtraction
[[sf_rescale_collinear]], the collinear counter terms
[[sf_rescale_dglap_t]] and for the case, in which we have an emitter
in the initial state, we rescale the kinematics for it using
[[sf_rescale_real_t]]. The references are arXiv:0709.2092,
Eqs.~(2.35)-(2.42).
Obviously, it is completely irrelevant, which beam is treated.
It becomes problematic when handling $ep$ collisions.
Gfortran 7/8/9 bug, has to remain in the main module:
<<Instances: term instance: TBP>>=
procedure :: evaluate_scaled_sf_chains => &
term_instance_evaluate_scaled_sf_chains
<<Instances: main procedures>>=
subroutine term_instance_evaluate_scaled_sf_chains (term, kin)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(inout) :: kin
class(sf_rescale_t), allocatable :: sf_rescale
if (.not. term%pcm%has_pdfs) return
if (term%nlo_type == NLO_REAL) then
if (term%is_subtraction ()) then
allocate (sf_rescale_collinear_t :: sf_rescale)
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
select type (sf_rescale)
type is (sf_rescale_collinear_t)
call sf_rescale%set (pcm_work%real_kinematics%xi_tilde)
end select
end select
call kin%sf_chain%evaluate (term%get_fac_scale (), &
term%negative_sf, sf_rescale)
deallocate (sf_rescale)
else if (kin%emitter >= 0 .and. kin%emitter <= kin%n_in) then
allocate (sf_rescale_real_t :: sf_rescale)
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
select type (sf_rescale)
type is (sf_rescale_real_t)
call sf_rescale%set (pcm_work%real_kinematics%xi_tilde * &
pcm_work%real_kinematics%xi_max (kin%i_phs), &
pcm_work%real_kinematics%y (kin%i_phs))
end select
end select
call kin%sf_chain%evaluate (term%get_fac_scale (), &
term%negative_sf, sf_rescale)
deallocate (sf_rescale)
else
call kin%sf_chain%evaluate (term%get_fac_scale (), term%negative_sf)
end if
else if (term%nlo_type == NLO_DGLAP) then
allocate (sf_rescale_dglap_t :: sf_rescale)
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
select type (sf_rescale)
type is (sf_rescale_dglap_t)
call sf_rescale%set (pcm_work%isr_kinematics%z)
end select
end select
call kin%sf_chain%evaluate (term%get_fac_scale (), &
term%negative_sf, sf_rescale)
deallocate (sf_rescale)
end if
end subroutine term_instance_evaluate_scaled_sf_chains
@ %def term_instance_evaluate_scaled_sf_chains
@ Evaluate the extra data that we need for processing the object as a
physical event.
<<Instances: term instance: TBP>>=
procedure :: evaluate_event_data => term_instance_evaluate_event_data
<<Instances: sub interfaces>>=
module subroutine term_instance_evaluate_event_data (term)
class(term_instance_t), intent(inout) :: term
end subroutine term_instance_evaluate_event_data
<<Instances: procedures>>=
module subroutine term_instance_evaluate_event_data (term)
class(term_instance_t), intent(inout) :: term
logical :: only_momenta
only_momenta = term%nlo_type > BORN
call term%isolated%evaluate_event_data (only_momenta)
call term%connected%evaluate_event_data (only_momenta)
end subroutine term_instance_evaluate_event_data
@ %def term_instance_evaluate_event_data
@
<<Instances: term instance: TBP>>=
procedure :: set_fac_scale => term_instance_set_fac_scale
<<Instances: sub interfaces>>=
module subroutine term_instance_set_fac_scale (term, fac_scale)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: fac_scale
end subroutine term_instance_set_fac_scale
<<Instances: procedures>>=
module subroutine term_instance_set_fac_scale (term, fac_scale)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: fac_scale
term%fac_scale = fac_scale
end subroutine term_instance_set_fac_scale
@ %def term_instance_set_fac_scale
@ Return data that might be useful for external processing. The
factorization scale and renormalization scale are identical to the
general scale if not explicitly set:
<<Instances: term instance: TBP>>=
procedure :: get_fac_scale => term_instance_get_fac_scale
procedure :: get_ren_scale => term_instance_get_ren_scale
<<Instances: sub interfaces>>=
module function term_instance_get_fac_scale (term) result (fac_scale)
class(term_instance_t), intent(in) :: term
real(default) :: fac_scale
end function term_instance_get_fac_scale
module function term_instance_get_ren_scale (term) result (ren_scale)
class(term_instance_t), intent(in) :: term
real(default) :: ren_scale
end function term_instance_get_ren_scale
<<Instances: procedures>>=
module function term_instance_get_fac_scale (term) result (fac_scale)
class(term_instance_t), intent(in) :: term
real(default) :: fac_scale
if (allocated (term%fac_scale)) then
fac_scale = term%fac_scale
else
fac_scale = term%scale
end if
end function term_instance_get_fac_scale
module function term_instance_get_ren_scale (term) result (ren_scale)
class(term_instance_t), intent(in) :: term
real(default) :: ren_scale
if (allocated (term%ren_scale)) then
ren_scale = term%ren_scale
else
ren_scale = term%scale
end if
end function term_instance_get_ren_scale
@ %def term_instance_get_fac_scale term_instance_get_ren_scale
@ We take the strong coupling from the process core. The value is calculated
when a new event is requested, so we should call it only after the event has
been evaluated. If it is not available there (a negative number is returned),
we take the value stored in the term configuration, which should be determined
by the model. If the model does not provide a value, the result is zero.
<<Instances: term instance: TBP>>=
procedure :: get_alpha_s => term_instance_get_alpha_s
<<Instances: sub interfaces>>=
module function term_instance_get_alpha_s (term, core) result (alpha_s)
class(term_instance_t), intent(in) :: term
class(prc_core_t), intent(in) :: core
real(default) :: alpha_s
end function term_instance_get_alpha_s
<<Instances: procedures>>=
module function term_instance_get_alpha_s (term, core) result (alpha_s)
class(term_instance_t), intent(in) :: term
class(prc_core_t), intent(in) :: core
real(default) :: alpha_s
alpha_s = core%get_alpha_s (term%core_state)
if (alpha_s < zero) alpha_s = term%config%alpha_s
end function term_instance_get_alpha_s
@ %def term_instance_get_alpha_s
@ The second helicity for [[helicities]] comes with a minus sign
because OpenLoops inverts the helicity index of antiparticles.
<<Instances: term instance: TBP>>=
procedure :: get_helicities_for_openloops => &
term_instance_get_helicities_for_openloops
<<Instances: sub interfaces>>=
module subroutine term_instance_get_helicities_for_openloops &
(term, helicities)
class(term_instance_t), intent(in) :: term
integer, dimension(:,:), allocatable, intent(out) :: helicities
end subroutine term_instance_get_helicities_for_openloops
<<Instances: procedures>>=
module subroutine term_instance_get_helicities_for_openloops &
(term, helicities)
class(term_instance_t), intent(in) :: term
integer, dimension(:,:), allocatable, intent(out) :: helicities
type(helicity_t), dimension(:), allocatable :: hel
type(quantum_numbers_t), dimension(:,:), allocatable :: qn
type(quantum_numbers_mask_t) :: qn_mask
integer :: h, i, j, n_in
call qn_mask%set_sub (1)
call term%isolated%trace%get_quantum_numbers_mask (qn_mask, qn)
n_in = term%int_hard%get_n_in ()
allocate (helicities (size (qn, dim=1), n_in))
allocate (hel (n_in))
do i = 1, size (qn, dim=1)
do j = 1, n_in
hel(j) = qn(i, j)%get_helicity ()
call hel(j)%diagonalize ()
call hel(j)%get_indices (h, h)
helicities (i, j) = h
end do
end do
end subroutine term_instance_get_helicities_for_openloops
@ %def term_instance_get_helicities_for_openloops
@
<<Instances: term instance: TBP>>=
procedure :: get_i_term_global => term_instance_get_i_term_global
<<Instances: sub interfaces>>=
elemental module function term_instance_get_i_term_global &
(term) result (i_term)
integer :: i_term
class(term_instance_t), intent(in) :: term
end function term_instance_get_i_term_global
<<Instances: procedures>>=
elemental module function term_instance_get_i_term_global &
(term) result (i_term)
integer :: i_term
class(term_instance_t), intent(in) :: term
i_term = term%config%i_term_global
end function term_instance_get_i_term_global
@ %def term_instance_get_i_term_global
@
<<Instances: term instance: TBP>>=
procedure :: is_subtraction => term_instance_is_subtraction
<<Instances: sub interfaces>>=
elemental module function term_instance_is_subtraction (term) result (sub)
logical :: sub
class(term_instance_t), intent(in) :: term
end function term_instance_is_subtraction
<<Instances: procedures>>=
elemental module function term_instance_is_subtraction (term) result (sub)
logical :: sub
class(term_instance_t), intent(in) :: term
sub = term%config%i_term_global == term%config%i_sub
end function term_instance_is_subtraction
@ %def term_instance_is_subtraction
@ Retrieve [[n_sub]] which was calculated in [[process_term_setup_interaction]].
<<Instances: term instance: TBP>>=
procedure :: get_n_sub => term_instance_get_n_sub
procedure :: get_n_sub_color => term_instance_get_n_sub_color
procedure :: get_n_sub_spin => term_instance_get_n_sub_spin
<<Instances: sub interfaces>>=
module function term_instance_get_n_sub (term) result (n_sub)
integer :: n_sub
class(term_instance_t), intent(in) :: term
end function term_instance_get_n_sub
module function term_instance_get_n_sub_color (term) result (n_sub_color)
integer :: n_sub_color
class(term_instance_t), intent(in) :: term
end function term_instance_get_n_sub_color
module function term_instance_get_n_sub_spin (term) result (n_sub_spin)
integer :: n_sub_spin
class(term_instance_t), intent(in) :: term
end function term_instance_get_n_sub_spin
<<Instances: procedures>>=
module function term_instance_get_n_sub (term) result (n_sub)
integer :: n_sub
class(term_instance_t), intent(in) :: term
n_sub = term%config%n_sub
end function term_instance_get_n_sub
module function term_instance_get_n_sub_color (term) result (n_sub_color)
integer :: n_sub_color
class(term_instance_t), intent(in) :: term
n_sub_color = term%config%n_sub_color
end function term_instance_get_n_sub_color
module function term_instance_get_n_sub_spin (term) result (n_sub_spin)
integer :: n_sub_spin
class(term_instance_t), intent(in) :: term
n_sub_spin = term%config%n_sub_spin
end function term_instance_get_n_sub_spin
@ %def term_instance_get_n_sub
@ %def term_instance_get_n_sub_color
@ %def term_instance_get_n_sub_spin
@
\subsection{The process instance}
NOTE: The description below represents the intended structure after
refactoring and disentangling the FKS-NLO vs. LO algorithm dependencies.
A process instance contains all process data that depend on the
sampling point and thus change often. In essence, it is an event
record at the elementary (parton) level. We do not call it such, to
avoid confusion with the actual event records. If decays are
involved, the latter are compositions of several elementary processes
(i.e., their instances).
We implement the process instance as an extension of the
[[mci_sampler_t]] that we need for computing integrals and generate
events.
The base type contains: the [[integrand]], the [[selected_channel]],
the two-dimensional array [[x]] of parameters, and the one-dimensional
array [[f]] of Jacobians. These subobjects are public and used for
communicating with the multi-channel integrator.
The [[process]] pointer accesses the process of which this record is
an instance. It is required whenever the calculation needs invariant
configuration data, therefore the process should stay in memory for
the whole lifetime of its instances.
The [[pcm]] pointer is a shortcut to the [[pcm]] (process-component
manager) component of the associated process, which we need wherever
the calculation depends on the overall algorithm.
The [[pcm_work]] component is the workspace for the [[pcm]] object
referenced above.
The [[evaluation_status]] code is used to check the current status.
In particular, failure at various stages is recorded there.
The [[count]] object records process evaluations, broken down
according to status.
The [[sqme]] value is the single real number that results from
evaluating and tracing the kinematics and matrix elements. This
is the number that is handed over to an integration routine.
The [[weight]] value is the event weight. It is defined when an event
has been generated from the process instance, either weighted or
unweighted. The value is the [[sqme]] value times Jacobian weights
from the integration, or unity, respectively.
The [[i_mci]] index chooses a subset of components that are associated with
a common parameter set and integrator, i.e., that are added coherently.
The [[sf_chain]] subobject is a realization of the beam and
structure-function configuration in the [[process]] object. It is not
used for calculation directly but serves as the template for the
sf-chain instances that are contained in the [[component]] objects.
The [[kinematics]] array contains the set of phase-space points that
are associated with the current calculation. The entries may correspond
to different process components and terms. (TODO wk 19-02-22: Not implemented yet.)
TODO wk 19-02-22: May include extra arrays for storing (squared) amplitude
data. The [[term]] data set may be reduced to just results, or
be removed altogether.
The [[term]] subobjects are workspace for evaluating kinematics,
matrix elements, cuts etc. The array entries correspond to the [[term]]
configuration entries in the associated process object.
The [[mci_work]] subobject contains the array of real input parameters (random
numbers) that generates the kinematical point. It also contains the workspace
for the MC integrators. The active entry of the [[mci_work]] array is
selected by the [[i_mci]] index above.
The [[hook]] pointer accesses a list of after evaluate objects which are
evalutated after the matrix element.
<<Instances: public>>=
public :: process_instance_t
<<Instances: types>>=
type, extends (mci_sampler_t) :: process_instance_t
type(process_t), pointer :: process => null ()
class(pcm_t), pointer :: pcm => null ()
class(pcm_workspace_t), allocatable :: pcm_work
integer :: evaluation_status = STAT_UNDEFINED
real(default) :: sqme = 0
real(default) :: weight = 0
real(default) :: excess = 0
integer :: n_dropped = 0
integer :: i_mci = 0
integer :: selected_channel = 0
type(sf_chain_t) :: sf_chain
type(kinematics_t), dimension(:), allocatable :: kin
type(term_instance_t), dimension(:), allocatable :: term
type(mci_work_t), dimension(:), allocatable :: mci_work
class(process_instance_hook_t), pointer :: hook => null ()
contains
<<Instances: process instance: TBP>>
end type process_instance_t
@ %def process_instance
@
Wrapper type for storing pointers to process instance objects in arrays.
<<Instances: public>>=
public :: process_instance_ptr_t
<<Instances: types>>=
type :: process_instance_ptr_t
type(process_instance_t), pointer :: p => null ()
end type process_instance_ptr_t
@ %def process_instance_ptr_t
@ The process hooks are first-in-last-out list of objects which are evaluated
after the phase space and matrixelement are evaluated. It is possible to
retrieve the sampler object and read the sampler information.
The hook object are part of the [[process_instance]] and therefore, share a
common lifetime. A data transfer, after the usual lifetime of the
[[process_instance]], is not provided, as such the finalisation procedure has to take care
of this! E.g. write the object to file from which later the collected
information can then be retrieved.
<<Instances: public>>=
public :: process_instance_hook_t
<<Instances: types>>=
type, abstract :: process_instance_hook_t
class(process_instance_hook_t), pointer :: next => null ()
contains
procedure(process_instance_hook_init), deferred :: init
procedure(process_instance_hook_final), deferred :: final
procedure(process_instance_hook_evaluate), deferred :: evaluate
end type process_instance_hook_t
@ %def process_instance_hook_t
@ We have to provide an [[init]], a [[final]] procedure and, for after evaluation, the
[[evaluate]] procedure.
The [[init]] procedures accesses [[var_list]] and current [[instance]] object.
<<Instances: public>>=
public :: process_instance_hook_final, process_instance_hook_evaluate
<<Instances: interfaces>>=
abstract interface
subroutine process_instance_hook_init (hook, var_list, instance, pdf_data)
import :: process_instance_hook_t, var_list_t, process_instance_t, pdf_data_t
class(process_instance_hook_t), intent(inout), target :: hook
type(var_list_t), intent(in) :: var_list
class(process_instance_t), intent(in), target :: instance
type(pdf_data_t), intent(in), optional :: pdf_data
end subroutine process_instance_hook_init
subroutine process_instance_hook_final (hook)
import :: process_instance_hook_t
class(process_instance_hook_t), intent(inout) :: hook
end subroutine process_instance_hook_final
subroutine process_instance_hook_evaluate (hook, instance)
import :: process_instance_hook_t, process_instance_t
class(process_instance_hook_t), intent(inout) :: hook
class(process_instance_t), intent(in), target :: instance
end subroutine process_instance_hook_evaluate
end interface
@ %def process_instance_hook_final, process_instance_hook_evaluate
@ The output routine contains a header with the most relevant
information about the process, copied from
[[process_metadata_write]]. We mark the active components by an asterisk.
The next section is the MC parameter input. The following sections
are written only if the evaluation status is beyond setting the
parameters, or if the [[verbose]] option is set.
<<Instances: process instance: TBP>>=
procedure :: write_header => process_instance_write_header
procedure :: write => process_instance_write
<<Instances: sub interfaces>>=
module subroutine process_instance_write_header (object, unit, testflag)
class(process_instance_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
end subroutine process_instance_write_header
module subroutine process_instance_write (object, unit, testflag)
class(process_instance_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
end subroutine process_instance_write
<<Instances: procedures>>=
module subroutine process_instance_write_header (object, unit, testflag)
class(process_instance_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
integer :: u
u = given_output_unit (unit)
call write_separator (u, 2)
if (associated (object%process)) then
call object%process%write_meta (u, testflag)
else
write (u, "(1x,A)") "Process instance [undefined process]"
return
end if
write (u, "(3x,A)", advance = "no") "status = "
select case (object%evaluation_status)
case (STAT_INITIAL); write (u, "(A)") "initialized"
case (STAT_ACTIVATED); write (u, "(A)") "activated"
case (STAT_BEAM_MOMENTA); write (u, "(A)") "beam momenta set"
case (STAT_FAILED_KINEMATICS); write (u, "(A)") "failed kinematics"
case (STAT_SEED_KINEMATICS); write (u, "(A)") "seed kinematics"
case (STAT_HARD_KINEMATICS); write (u, "(A)") "hard kinematics"
case (STAT_EFF_KINEMATICS); write (u, "(A)") "effective kinematics"
case (STAT_FAILED_CUTS); write (u, "(A)") "failed cuts"
case (STAT_PASSED_CUTS); write (u, "(A)") "passed cuts"
case (STAT_EVALUATED_TRACE); write (u, "(A)") "evaluated trace"
call write_separator (u)
write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme
case (STAT_EVENT_COMPLETE); write (u, "(A)") "event complete"
call write_separator (u)
write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme
write (u, "(3x,A,ES19.12)") "weight = ", object%weight
if (.not. vanishes (object%excess)) &
write (u, "(3x,A,ES19.12)") "excess = ", object%excess
case default; write (u, "(A)") "undefined"
end select
if (object%i_mci /= 0) then
call write_separator (u)
call object%mci_work(object%i_mci)%write (u, testflag)
end if
call write_separator (u, 2)
end subroutine process_instance_write_header
module subroutine process_instance_write (object, unit, testflag)
class(process_instance_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
integer :: u, i
u = given_output_unit (unit)
call object%write_header (u)
if (object%evaluation_status >= STAT_BEAM_MOMENTA) then
call object%sf_chain%write (u)
call write_separator (u, 2)
if (object%evaluation_status >= STAT_SEED_KINEMATICS) then
if (object%evaluation_status >= STAT_HARD_KINEMATICS) then
call write_separator (u, 2)
write (u, "(1x,A)") "Active terms:"
if (any (object%term%active)) then
do i = 1, size (object%term)
if (object%term(i)%active) then
call write_separator (u)
call object%term(i)%write (u, &
kin = object%kin(i), &
show_eff_state = &
object%evaluation_status >= STAT_EFF_KINEMATICS, &
testflag = testflag)
end if
end do
end if
end if
call write_separator (u, 2)
end if
end if
end subroutine process_instance_write
@ %def process_instance_write_header
@ %def process_instance_write
@ Initialization connects the instance with a process. All initial
information is transferred from the process object. The process
object contains templates for the interaction subobjects (beam and
term), but no evaluators. The initialization routine
creates evaluators for the matrix element trace, other evaluators
are left untouched.
Before we start generating, we double-check if the process library
has been updated after the process was initializated
([[check_library_sanity]]). This may happen if between integration
and event generation the library has been recompiled, so all links
become broken.
The [[instance]] object must have the [[target]] attribute (also in
any caller) since the initialization routine assigns various pointers
to subobject of [[instance]].
<<Instances: process instance: TBP>>=
procedure :: init => process_instance_init
<<Instances: sub interfaces>>=
module subroutine process_instance_init (instance, process)
class(process_instance_t), intent(out), target :: instance
type(process_t), intent(inout), target :: process
end subroutine process_instance_init
<<Instances: procedures>>=
module subroutine process_instance_init (instance, process)
class(process_instance_t), intent(out), target :: instance
type(process_t), intent(inout), target :: process
integer :: i
class(pcm_t), pointer :: pcm
type(process_term_t), pointer :: term
type(var_list_t), pointer :: var_list
integer :: i_born, i_real, i_real_fin, i_component
if (debug_on) call msg_debug &
(D_PROCESS_INTEGRATION, "process_instance_init")
instance%process => process
instance%pcm => process%get_pcm_ptr ()
call instance%process%check_library_sanity ()
call instance%setup_sf_chain (process%get_beam_config_ptr ())
allocate (instance%mci_work (process%get_n_mci ()))
do i = 1, size (instance%mci_work)
call instance%process%init_mci_work (instance%mci_work(i), i)
end do
call instance%process%reset_selected_cores ()
pcm => instance%process%get_pcm_ptr ()
call pcm%allocate_workspace (instance%pcm_work)
select type (pcm)
type is (pcm_nlo_t)
!!! The process is kept when the integration is finalized, but not the
!!! process_instance. Thus, we check whether pcm has been initialized
!!! but set up the pcm_work each time.
i_real_fin = process%get_associated_real_fin (1)
if (.not. pcm%initialized) then
i_born = pcm%get_i_core (pcm%i_born)
i_real = pcm%get_i_core (pcm%i_real)
call pcm%init_qn (process%get_model_ptr ())
if (i_real_fin > 0) call pcm%allocate_ps_matching ()
var_list => process%get_var_list_ptr ()
if (var_list%get_sval (var_str ("$dalitz_plot")) /= var_str ('')) &
call pcm%activate_dalitz_plot (var_list%get_sval (var_str ("$dalitz_plot")))
end if
pcm%initialized = .true.
select type (pcm_work => instance%pcm_work)
type is (pcm_nlo_workspace_t)
call pcm_work%init_config (pcm, &
process%component_can_be_integrated (), &
process%get_nlo_type_component (), process%get_energy (), &
i_real_fin, process%get_model_ptr ())
end select
end select
! TODO wk-03-01 n_terms will eventually acquire a different meaning
allocate (instance%kin (process%get_n_terms ()))
do i = 1, process%get_n_terms ()
term => process%get_term_ptr (i)
i_component = term%i_component
call instance%kin(i)%configure (pcm, instance%pcm_work, &
instance%sf_chain, &
process%get_beam_config_ptr (), &
process%get_phs_config (i_component), &
process%get_nlo_type_component (i_component), &
term%i_sub == i)
end do
! TODO wk-03-01 n_terms will eventually acquire a different meaning
allocate (instance%term (process%get_n_terms ()))
do i = 1, process%get_n_terms ()
call instance%term(i)%configure (process, i, instance%pcm_work, &
instance%sf_chain, instance%kin(i))
end do
call instance%set_i_mci_to_real_component ()
call instance%find_same_kinematics ()
instance%evaluation_status = STAT_INITIAL
end subroutine process_instance_init
@ %def process_instance_init
@
@ Finalize all subobjects that may contain allocated pointers.
<<Instances: process instance: TBP>>=
procedure :: final => process_instance_final
<<Instances: sub interfaces>>=
module subroutine process_instance_final (instance)
class(process_instance_t), intent(inout) :: instance
end subroutine process_instance_final
<<Instances: procedures>>=
module subroutine process_instance_final (instance)
class(process_instance_t), intent(inout) :: instance
class(process_instance_hook_t), pointer :: current
integer :: i
instance%process => null ()
if (allocated (instance%mci_work)) then
do i = 1, size (instance%mci_work)
call instance%mci_work(i)%final ()
end do
deallocate (instance%mci_work)
end if
call instance%sf_chain%final ()
if (allocated (instance%kin)) then
do i = 1, size (instance%kin)
call instance%kin(i)%final ()
end do
deallocate (instance%kin)
end if
if (allocated (instance%term)) then
do i = 1, size (instance%term)
call instance%term(i)%final ()
end do
deallocate (instance%term)
end if
call instance%pcm_work%final ()
instance%evaluation_status = STAT_UNDEFINED
do while (associated (instance%hook))
current => instance%hook
call current%final ()
instance%hook => current%next
deallocate (current)
end do
instance%hook => null ()
end subroutine process_instance_final
@ %def process_instance_final
@ Revert the process instance to initial state. We do not deallocate
anything, just reset the state index and deactivate all components and
terms.
We do not reset the choice of the MCI set [[i_mci]] unless this is
required explicitly.
<<Instances: process instance: TBP>>=
procedure :: reset => process_instance_reset
<<Instances: sub interfaces>>=
module subroutine process_instance_reset (instance, reset_mci)
class(process_instance_t), intent(inout), target :: instance
logical, intent(in), optional :: reset_mci
end subroutine process_instance_reset
<<Instances: procedures>>=
module subroutine process_instance_reset (instance, reset_mci)
class(process_instance_t), intent(inout), target :: instance
logical, intent(in), optional :: reset_mci
integer :: i
call instance%process%reset_selected_cores ()
do i = 1, size (instance%term)
call instance%term(i)%reset ()
end do
instance%term%checked = .false.
instance%term%passed = .false.
instance%kin%new_seed = .true.
if (present (reset_mci)) then
if (reset_mci) instance%i_mci = 0
end if
instance%selected_channel = 0
instance%evaluation_status = STAT_INITIAL
end subroutine process_instance_reset
@ %def process_instance_reset
@
\subsubsection{Integration and event generation}
The sampler test should just evaluate the squared matrix element [[n_calls]]
times, discarding the results, and return. This can be done before
integration, e.g., for timing estimates.
<<Instances: process instance: TBP>>=
procedure :: sampler_test => process_instance_sampler_test
<<Instances: sub interfaces>>=
module subroutine process_instance_sampler_test (instance, i_mci, n_calls)
class(process_instance_t), intent(inout), target :: instance
integer, intent(in) :: i_mci
integer, intent(in) :: n_calls
end subroutine process_instance_sampler_test
<<Instances: procedures>>=
module subroutine process_instance_sampler_test (instance, i_mci, n_calls)
class(process_instance_t), intent(inout), target :: instance
integer, intent(in) :: i_mci
integer, intent(in) :: n_calls
integer :: i_mci_work
i_mci_work = instance%process%get_i_mci_work (i_mci)
call instance%choose_mci (i_mci_work)
call instance%reset_counter ()
call instance%process%sampler_test (instance, n_calls, i_mci_work)
call instance%process%set_counter_mci_entry (i_mci_work, instance%get_counter ())
end subroutine process_instance_sampler_test
@ %def process_instance_sampler_test
@ Generate a weighted event. We select one of the available MCI
integrators by its index [[i_mci]] and thus generate an event for the
associated (group of) process component(s). The arguments exactly
correspond to the initializer and finalizer above.
The resulting event is stored in the [[process_instance]] object,
which also holds the workspace of the integrator.
Note: The [[process]] object contains the random-number state, which
changes for each event.
Otherwise, all volatile data are inside the [[instance]] object.
<<Instances: process instance: TBP>>=
procedure :: generate_weighted_event => &
process_instance_generate_weighted_event
<<Instances: sub interfaces>>=
module subroutine process_instance_generate_weighted_event (instance, i_mci)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
end subroutine process_instance_generate_weighted_event
<<Instances: procedures>>=
module subroutine process_instance_generate_weighted_event (instance, i_mci)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
integer :: i_mci_work
i_mci_work = instance%process%get_i_mci_work (i_mci)
call instance%choose_mci (i_mci_work)
associate (mci_work => instance%mci_work(i_mci_work))
call instance%process%generate_weighted_event &
(i_mci_work, mci_work, instance, &
instance%keep_failed_events ())
end associate
end subroutine process_instance_generate_weighted_event
@ %def process_instance_generate_weighted_event
@
<<Instances: process instance: TBP>>=
procedure :: generate_unweighted_event => &
process_instance_generate_unweighted_event
<<Instances: sub interfaces>>=
module subroutine process_instance_generate_unweighted_event &
(instance, i_mci)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
end subroutine process_instance_generate_unweighted_event
<<Instances: procedures>>=
module subroutine process_instance_generate_unweighted_event (instance, i_mci)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
integer :: i_mci_work
i_mci_work = instance%process%get_i_mci_work (i_mci)
call instance%choose_mci (i_mci_work)
associate (mci_work => instance%mci_work(i_mci_work))
call instance%process%generate_unweighted_event &
(i_mci_work, mci_work, instance)
end associate
end subroutine process_instance_generate_unweighted_event
@ %def process_instance_generate_unweighted_event
@ This replaces the event generation methods for the situation that the
process instance object has been filled by other means (i.e., reading
and/or recalculating its contents). We just have to fill in missing
MCI data, especially the event weight.
<<Instances: process instance: TBP>>=
procedure :: recover_event => process_instance_recover_event
<<Instances: sub interfaces>>=
module subroutine process_instance_recover_event (instance)
class(process_instance_t), intent(inout) :: instance
end subroutine process_instance_recover_event
<<Instances: procedures>>=
module subroutine process_instance_recover_event (instance)
class(process_instance_t), intent(inout) :: instance
integer :: i_mci
i_mci = instance%i_mci
call instance%process%set_i_mci_work (i_mci)
associate (mci_instance => instance%mci_work(i_mci)%mci)
call mci_instance%fetch (instance, instance%selected_channel)
end associate
end subroutine process_instance_recover_event
@ %def process_instance_recover_event
@ Activate the components and terms that correspond to a currently
selected MCI parameter set.
<<Instances: process instance: TBP>>=
procedure :: activate => process_instance_activate
<<Instances: sub interfaces>>=
module subroutine process_instance_activate (instance)
class(process_instance_t), intent(inout) :: instance
end subroutine process_instance_activate
<<Instances: procedures>>=
module subroutine process_instance_activate (instance)
class(process_instance_t), intent(inout) :: instance
integer :: i, j
integer, dimension(:), allocatable :: i_term
associate (mci_work => instance%mci_work(instance%i_mci))
call instance%process%select_components &
(mci_work%get_active_components ())
end associate
associate (process => instance%process)
do i = 1, instance%process%get_n_components ()
if (instance%process%component_is_selected (i)) then
allocate (i_term (size (process%get_component_i_terms (i))))
i_term = process%get_component_i_terms (i)
do j = 1, size (i_term)
instance%term(i_term(j))%active = .true.
end do
end if
if (allocated (i_term)) deallocate (i_term)
end do
end associate
instance%evaluation_status = STAT_ACTIVATED
end subroutine process_instance_activate
@ %def process_instance_activate
@
<<Instances: process instance: TBP>>=
procedure :: find_same_kinematics => process_instance_find_same_kinematics
<<Instances: sub interfaces>>=
module subroutine process_instance_find_same_kinematics (instance)
class(process_instance_t), intent(inout) :: instance
end subroutine process_instance_find_same_kinematics
<<Instances: procedures>>=
module subroutine process_instance_find_same_kinematics (instance)
class(process_instance_t), intent(inout) :: instance
integer :: i_term1, i_term2, k, n_same
do i_term1 = 1, size (instance%term)
if (.not. allocated (instance%term(i_term1)%same_kinematics)) then
n_same = 1 !!! Index group includes the index of its term_instance
do i_term2 = 1, size (instance%term)
if (i_term1 == i_term2) cycle
if (compare_md5s (i_term1, i_term2)) n_same = n_same + 1
end do
allocate (instance%term(i_term1)%same_kinematics (n_same))
associate (same_kinematics1 => instance%term(i_term1)%same_kinematics)
same_kinematics1 = 0
k = 1
do i_term2 = 1, size (instance%term)
if (compare_md5s (i_term1, i_term2)) then
same_kinematics1(k) = i_term2
k = k + 1
end if
end do
do k = 1, size (same_kinematics1)
if (same_kinematics1(k) == i_term1) cycle
i_term2 = same_kinematics1(k)
allocate (instance%term(i_term2)%same_kinematics (n_same))
instance%term(i_term2)%same_kinematics = same_kinematics1
end do
end associate
end if
end do
contains
function compare_md5s (i, j) result (same)
logical :: same
integer, intent(in) :: i, j
character(32) :: md5sum_1, md5sum_2
integer :: mode_1, mode_2
mode_1 = 0; mode_2 = 0
select type (phs => instance%kin(i)%phs%config)
type is (phs_fks_config_t)
md5sum_1 = phs%md5sum_born_config
mode_1 = phs%mode
class default
md5sum_1 = phs%md5sum_phs_config
end select
select type (phs => instance%kin(j)%phs%config)
type is (phs_fks_config_t)
md5sum_2 = phs%md5sum_born_config
mode_2 = phs%mode
class default
md5sum_2 = phs%md5sum_phs_config
end select
same = (md5sum_1 == md5sum_2) .and. (mode_1 == mode_2)
end function compare_md5s
end subroutine process_instance_find_same_kinematics
@ %def process_instance_find_same_kinematics
@
<<Instances: process instance: TBP>>=
procedure :: transfer_same_kinematics => &
process_instance_transfer_same_kinematics
<<Instances: sub interfaces>>=
module subroutine process_instance_transfer_same_kinematics &
(instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
end subroutine process_instance_transfer_same_kinematics
<<Instances: procedures>>=
module subroutine process_instance_transfer_same_kinematics (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
integer :: i, i_term_same
associate (same_kinematics => instance%term(i_term)%same_kinematics)
do i = 1, size (same_kinematics)
i_term_same = same_kinematics(i)
instance%term(i_term_same)%p_seed = instance%term(i_term)%p_seed
associate (phs => instance%kin(i_term_same)%phs)
call phs%set_lorentz_transformation &
(instance%kin(i_term)%phs%get_lorentz_transformation ())
select type (phs)
type is (phs_fks_t)
call phs%set_momenta (instance%term(i_term_same)%p_seed)
if (i_term_same /= i_term) then
call phs%set_reference_frames (.false.)
end if
end select
end associate
instance%kin(i_term_same)%new_seed = .false.
end do
end associate
end subroutine process_instance_transfer_same_kinematics
@ %def process_instance_transfer_same_kinematics
@
<<Instances: process instance: TBP>>=
procedure :: redo_sf_chains => process_instance_redo_sf_chains
<<Instances: sub interfaces>>=
module subroutine process_instance_redo_sf_chains &
(instance, i_term, phs_channel)
class(process_instance_t), intent(inout) :: instance
integer, intent(in), dimension(:) :: i_term
integer, intent(in) :: phs_channel
end subroutine process_instance_redo_sf_chains
<<Instances: procedures>>=
module subroutine process_instance_redo_sf_chains &
(instance, i_term, phs_channel)
class(process_instance_t), intent(inout) :: instance
integer, intent(in), dimension(:) :: i_term
integer, intent(in) :: phs_channel
integer :: i
do i = 1, size (i_term)
call instance%kin(i_term(i))%redo_sf_chain &
(instance%mci_work(instance%i_mci), phs_channel)
end do
end subroutine process_instance_redo_sf_chains
@ %def process_instance_redo_sf_chains
@ Integrate the process, using a previously initialized process
instance. We select one of the available MCI integrators by its index
[[i_mci]] and thus integrate over (structure functions and) phase
space for the associated (group of) process component(s).
<<Instances: process instance: TBP>>=
procedure :: integrate => process_instance_integrate
<<Instances: sub interfaces>>=
module subroutine process_instance_integrate (instance, i_mci, &
n_it, n_calls, adapt_grids, adapt_weights, final, pacify)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
integer, intent(in) :: n_it
integer, intent(in) :: n_calls
logical, intent(in), optional :: adapt_grids
logical, intent(in), optional :: adapt_weights
logical, intent(in), optional :: final, pacify
end subroutine process_instance_integrate
<<Instances: procedures>>=
module subroutine process_instance_integrate (instance, i_mci, &
n_it, n_calls, adapt_grids, adapt_weights, final, pacify)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
integer, intent(in) :: n_it
integer, intent(in) :: n_calls
logical, intent(in), optional :: adapt_grids
logical, intent(in), optional :: adapt_weights
logical, intent(in), optional :: final, pacify
integer :: nlo_type, i_mci_work
nlo_type = instance%process%get_component_nlo_type (i_mci)
i_mci_work = instance%process%get_i_mci_work (i_mci)
call instance%choose_mci (i_mci_work)
call instance%reset_counter ()
associate (mci_work => instance%mci_work(i_mci_work), &
process => instance%process)
call process%integrate (i_mci_work, mci_work, &
instance, n_it, n_calls, adapt_grids, adapt_weights, &
final, pacify, nlo_type = nlo_type)
call process%set_counter_mci_entry (i_mci_work, instance%get_counter ())
end associate
end subroutine process_instance_integrate
@ %def process_instance_integrate
@ Subroutine of the initialization above: initialize the beam and
structure-function chain template. We establish pointers to the
configuration data, so [[beam_config]] must have a [[target]]
attribute.
The resulting chain is not used directly for calculation. It will
acquire instances which are stored in the process-component instance
objects.
<<Instances: process instance: TBP>>=
procedure :: setup_sf_chain => process_instance_setup_sf_chain
<<Instances: sub interfaces>>=
module subroutine process_instance_setup_sf_chain (instance, config)
class(process_instance_t), intent(inout) :: instance
type(process_beam_config_t), intent(in), target :: config
end subroutine process_instance_setup_sf_chain
<<Instances: procedures>>=
module subroutine process_instance_setup_sf_chain (instance, config)
class(process_instance_t), intent(inout) :: instance
type(process_beam_config_t), intent(in), target :: config
integer :: n_strfun
n_strfun = config%n_strfun
if (n_strfun /= 0) then
call instance%sf_chain%init (config%data, config%sf)
else
call instance%sf_chain%init (config%data)
end if
if (config%sf_trace) then
call instance%sf_chain%setup_tracing (config%sf_trace_file)
end if
end subroutine process_instance_setup_sf_chain
@ %def process_instance_setup_sf_chain
@ This initialization routine should be called only for process
instances which we intend as a source for physical events. It
initializes the evaluators in the parton states of the terms. They
describe the (semi-)exclusive transition matrix and the distribution
of color flow for the partonic process, convoluted with the beam and
structure-function chain.
If the model is not provided explicitly, we may use the model instance that
belongs to the process. However, an explicit model allows us to override
particle settings.
<<Instances: process instance: TBP>>=
procedure :: setup_event_data => process_instance_setup_event_data
<<Instances: sub interfaces>>=
module subroutine process_instance_setup_event_data &
(instance, model, i_core)
class(process_instance_t), intent(inout), target :: instance
class(model_data_t), intent(in), optional, target :: model
integer, intent(in), optional :: i_core
end subroutine process_instance_setup_event_data
<<Instances: procedures>>=
module subroutine process_instance_setup_event_data (instance, model, i_core)
class(process_instance_t), intent(inout), target :: instance
class(model_data_t), intent(in), optional, target :: model
integer, intent(in), optional :: i_core
class(model_data_t), pointer :: current_model
integer :: i
class(prc_core_t), pointer :: core => null ()
if (present (model)) then
current_model => model
else
current_model => instance%process%get_model_ptr ()
end if
do i = 1, size (instance%term)
associate (term => instance%term(i), kin => instance%kin(i))
if (associated (term%config)) then
core => instance%process%get_core_term (i)
call term%setup_event_data (kin, core, current_model)
end if
end associate
end do
core => null ()
end subroutine process_instance_setup_event_data
@ %def process_instance_setup_event_data
@ Choose a MC parameter set and the corresponding integrator.
The choice persists beyond calls of the [[reset]] method above. This method
is automatically called here.
<<Instances: process instance: TBP>>=
procedure :: choose_mci => process_instance_choose_mci
<<Instances: sub interfaces>>=
module subroutine process_instance_choose_mci (instance, i_mci)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
end subroutine process_instance_choose_mci
<<Instances: procedures>>=
module subroutine process_instance_choose_mci (instance, i_mci)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
instance%i_mci = i_mci
call instance%reset ()
end subroutine process_instance_choose_mci
@ %def process_instance_choose_mci
@ Explicitly set a MC parameter set. Works only if we are in initial
state. We assume that the length of the parameter set is correct.
After setting the parameters, activate the components and terms that
correspond to the chosen MC parameter set.
The [[warmup_flag]] is used when a dummy phase-space point is computed
for the warmup of e.g. OpenLoops helicities. The setting of the
the [[evaluation_status]] has to be avoided then.
<<Instances: process instance: TBP>>=
procedure :: set_mcpar => process_instance_set_mcpar
<<Instances: sub interfaces>>=
module subroutine process_instance_set_mcpar (instance, x, warmup_flag)
class(process_instance_t), intent(inout) :: instance
real(default), dimension(:), intent(in) :: x
logical, intent(in), optional :: warmup_flag
end subroutine process_instance_set_mcpar
<<Instances: procedures>>=
module subroutine process_instance_set_mcpar (instance, x, warmup_flag)
class(process_instance_t), intent(inout) :: instance
real(default), dimension(:), intent(in) :: x
logical, intent(in), optional :: warmup_flag
logical :: activate
activate = .true.; if (present (warmup_flag)) activate = .not. warmup_flag
if (instance%evaluation_status == STAT_INITIAL) then
associate (mci_work => instance%mci_work(instance%i_mci))
call mci_work%set (x)
end associate
if (activate) call instance%activate ()
end if
end subroutine process_instance_set_mcpar
@ %def process_instance_set_mcpar
@ Receive the beam momentum/momenta from a source interaction. This
applies to a cascade decay process instance, where the `beam' momentum
varies event by event.
The master beam momentum array is contained in the main structure
function chain subobject [[sf_chain]]. The sf-chain instance that
reside in the components will take their beam momenta from there.
The procedure transforms the instance status into
[[STAT_BEAM_MOMENTA]]. For process instance with fixed beam, this
intermediate status is skipped.
<<Instances: process instance: TBP>>=
procedure :: receive_beam_momenta => process_instance_receive_beam_momenta
<<Instances: sub interfaces>>=
module subroutine process_instance_receive_beam_momenta (instance)
class(process_instance_t), intent(inout) :: instance
end subroutine process_instance_receive_beam_momenta
<<Instances: procedures>>=
module subroutine process_instance_receive_beam_momenta (instance)
class(process_instance_t), intent(inout) :: instance
if (instance%evaluation_status >= STAT_INITIAL) then
call instance%sf_chain%receive_beam_momenta ()
instance%evaluation_status = STAT_BEAM_MOMENTA
end if
end subroutine process_instance_receive_beam_momenta
@ %def process_instance_receive_beam_momenta
@ Set the beam momentum/momenta explicitly. Otherwise, analogous to
the previous procedure.
<<Instances: process instance: TBP>>=
procedure :: set_beam_momenta => process_instance_set_beam_momenta
<<Instances: sub interfaces>>=
module subroutine process_instance_set_beam_momenta (instance, p)
class(process_instance_t), intent(inout) :: instance
type(vector4_t), dimension(:), intent(in) :: p
end subroutine process_instance_set_beam_momenta
<<Instances: procedures>>=
module subroutine process_instance_set_beam_momenta (instance, p)
class(process_instance_t), intent(inout) :: instance
type(vector4_t), dimension(:), intent(in) :: p
if (instance%evaluation_status >= STAT_INITIAL) then
call instance%sf_chain%set_beam_momenta (p)
instance%evaluation_status = STAT_BEAM_MOMENTA
end if
end subroutine process_instance_set_beam_momenta
@ %def process_instance_set_beam_momenta
@ Recover the initial beam momenta (those in the [[sf_chain]]
component), given a valid (recovered) [[sf_chain_instance]] in one of
the active components. We need to do this only if the lab frame is
not the c.m.\ frame, otherwise those beams would be fixed anyway.
<<Instances: process instance: TBP>>=
procedure :: recover_beam_momenta => process_instance_recover_beam_momenta
<<Instances: sub interfaces>>=
module subroutine process_instance_recover_beam_momenta (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
end subroutine process_instance_recover_beam_momenta
<<Instances: procedures>>=
module subroutine process_instance_recover_beam_momenta (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
if (.not. instance%process%lab_is_cm ()) then
if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
call instance%kin(i_term)%return_beam_momenta ()
end if
end if
end subroutine process_instance_recover_beam_momenta
@ %def process_instance_recover_beam_momenta
@ Explicitly choose MC integration channel. We assume here that the channel
count is identical for all active components.
<<Instances: process instance: TBP>>=
procedure :: select_channel => process_instance_select_channel
<<Instances: sub interfaces>>=
module subroutine process_instance_select_channel (instance, channel)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: channel
end subroutine process_instance_select_channel
<<Instances: procedures>>=
module subroutine process_instance_select_channel (instance, channel)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: channel
instance%selected_channel = channel
end subroutine process_instance_select_channel
@ %def process_instance_select_channel
@ First step of process evaluation: set up seed kinematics. That is, for each
active process component, compute a momentum array from the MC input
parameters.
If [[skip_term]] is set, we skip the component that accesses this
term. We can assume that the associated data have already been
recovered, and we are just computing the rest.
<<Instances: process instance: TBP>>=
procedure :: compute_seed_kinematics => &
process_instance_compute_seed_kinematics
<<Instances: sub interfaces>>=
module subroutine process_instance_compute_seed_kinematics &
(instance, recover, skip_term)
class(process_instance_t), intent(inout) :: instance
logical, intent(in), optional :: recover
integer, intent(in), optional :: skip_term
end subroutine process_instance_compute_seed_kinematics
<<Instances: procedures>>=
module subroutine process_instance_compute_seed_kinematics &
(instance, recover, skip_term)
class(process_instance_t), intent(inout) :: instance
logical, intent(in), optional :: recover
integer, intent(in), optional :: skip_term
integer :: channel, skip_component, i, j
logical :: success
integer, dimension(:), allocatable :: i_term
channel = instance%selected_channel
if (channel == 0) then
call msg_bug ("Compute seed kinematics: undefined integration channel")
end if
if (present (skip_term)) then
skip_component = instance%term(skip_term)%config%i_component
else
skip_component = 0
end if
if (present (recover)) then
if (recover) return
end if
if (instance%evaluation_status >= STAT_ACTIVATED) then
success = .true.
do i = 1, instance%process%get_n_components ()
if (i == skip_component) cycle
if (instance%process%component_is_selected (i)) then
allocate (i_term (size (instance%process%get_component_i_terms (i))))
i_term = instance%process%get_component_i_terms (i)
do j = 1, size (i_term)
associate (term => instance%term(i_term(j)), kin => instance%kin(i_term(j)))
if (kin%new_seed) then
call term%compute_seed_kinematics (kin, &
instance%mci_work(instance%i_mci), channel, success)
call instance%transfer_same_kinematics (i_term(j))
end if
if (.not. success) exit
select type (pcm => instance%pcm)
class is (pcm_nlo_t)
call term%evaluate_projections (kin)
call kin%evaluate_radiation_kinematics &
(instance%mci_work(instance%i_mci)%get_x_process ())
call kin%generate_fsr_in ()
call kin%compute_xi_ref_momenta (pcm%region_data, term%nlo_type)
end select
end associate
end do
end if
if (allocated (i_term)) deallocate (i_term)
end do
if (success) then
instance%evaluation_status = STAT_SEED_KINEMATICS
else
instance%evaluation_status = STAT_FAILED_KINEMATICS
end if
end if
associate (mci_work => instance%mci_work(instance%i_mci))
select type (pcm_work => instance%pcm_work)
class is (pcm_nlo_workspace_t)
call pcm_work%set_x_rad (mci_work%get_x_process ())
end select
end associate
end subroutine process_instance_compute_seed_kinematics
@ %def process_instance_compute_seed_kinematics
@
<<Instances: process instance: TBP>>=
procedure :: get_x_process => process_instance_get_x_process
<<Instances: sub interfaces>>=
pure module function process_instance_get_x_process (instance) result (x)
real(default), dimension(:), allocatable :: x
class(process_instance_t), intent(in) :: instance
end function process_instance_get_x_process
<<Instances: procedures>>=
pure module function process_instance_get_x_process (instance) result (x)
real(default), dimension(:), allocatable :: x
class(process_instance_t), intent(in) :: instance
allocate (x(size (instance%mci_work(instance%i_mci)%get_x_process ())))
x = instance%mci_work(instance%i_mci)%get_x_process ()
end function process_instance_get_x_process
@ %def process_instance_get_x_process
@
<<Instances: process instance: TBP>>=
procedure :: get_active_component_type => &
process_instance_get_active_component_type
<<Instances: sub interfaces>>=
pure module function process_instance_get_active_component_type &
(instance) result (nlo_type)
integer :: nlo_type
class(process_instance_t), intent(in) :: instance
end function process_instance_get_active_component_type
<<Instances: procedures>>=
pure module function process_instance_get_active_component_type &
(instance) result (nlo_type)
integer :: nlo_type
class(process_instance_t), intent(in) :: instance
nlo_type = instance%process%get_component_nlo_type (instance%i_mci)
end function process_instance_get_active_component_type
@ %def process_instance_get_active_component_type
@ Inverse: recover missing parts of the kinematics from the momentum
configuration, which we know for a single term and component. Given
a channel, reconstruct the MC parameter set.
<<Instances: process instance: TBP>>=
procedure :: recover_mcpar => process_instance_recover_mcpar
<<Instances: sub interfaces>>=
module subroutine process_instance_recover_mcpar (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
end subroutine process_instance_recover_mcpar
<<Instances: procedures>>=
module subroutine process_instance_recover_mcpar (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
integer :: channel, i
if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
channel = instance%selected_channel
if (channel == 0) then
call msg_bug ("Recover MC parameters: undefined integration channel")
end if
call instance%kin(i_term)%recover_mcpar &
(instance%mci_work(instance%i_mci), channel, instance%term(i_term)%p_seed)
if (instance%term(i_term)%nlo_type == NLO_REAL) then
do i = 1, size (instance%term)
if (i /= i_term .and. instance%term(i)%nlo_type == NLO_REAL) then
if (instance%term(i)%active) then
call instance%kin(i)%recover_mcpar &
(instance%mci_work(instance%i_mci), channel, &
instance%term(i)%p_seed)
end if
end if
end do
end if
end if
end subroutine process_instance_recover_mcpar
@ %def process_instance_recover_mcpar
@ This is part of [[recover_mcpar]], extracted for the case when there is
no phase space and parameters to recover, but we still need the structure
function kinematics for evaluation.
<<Instances: process instance: TBP>>=
procedure :: recover_sfchain => process_instance_recover_sfchain
<<Instances: sub interfaces>>=
module subroutine process_instance_recover_sfchain (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
end subroutine process_instance_recover_sfchain
<<Instances: procedures>>=
module subroutine process_instance_recover_sfchain (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
integer :: channel
if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
channel = instance%selected_channel
if (channel == 0) then
call msg_bug ("Recover sfchain: undefined integration channel")
end if
call instance%kin(i_term)%recover_sfchain &
(channel, instance%term(i_term)%p_seed)
end if
end subroutine process_instance_recover_sfchain
@ %def process_instance_recover_sfchain
@ Second step of process evaluation: compute all momenta, for all active
components, from the seed kinematics.
<<Instances: process instance: TBP>>=
procedure :: compute_hard_kinematics => &
process_instance_compute_hard_kinematics
<<Instances: sub interfaces>>=
module subroutine process_instance_compute_hard_kinematics &
(instance, recover, skip_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in), optional :: skip_term
logical, intent(in), optional :: recover
end subroutine process_instance_compute_hard_kinematics
<<Instances: procedures>>=
module subroutine process_instance_compute_hard_kinematics &
(instance, recover, skip_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in), optional :: skip_term
logical, intent(in), optional :: recover
integer :: i
logical :: success
success = .true.
if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then
do i = 1, size (instance%term)
associate (term => instance%term(i), kin => instance%kin(i))
if (term%active) then
call term%compute_hard_kinematics &
(kin, recover, skip_term, success)
if (.not. success) exit
!!! Ren scale is zero when this is commented out! Understand!
if (term%nlo_type == NLO_REAL) &
call kin%redo_sf_chain (instance%mci_work(instance%i_mci), &
instance%selected_channel)
end if
end associate
end do
if (success) then
instance%evaluation_status = STAT_HARD_KINEMATICS
else
instance%evaluation_status = STAT_FAILED_KINEMATICS
end if
end if
end subroutine process_instance_compute_hard_kinematics
@ %def process_instance_setup_compute_hard_kinematics
@ Inverse: recover seed kinematics. We know the beam momentum
configuration and the outgoing momenta of the effective interaction,
for one specific term.
<<Instances: process instance: TBP>>=
procedure :: recover_seed_kinematics => &
process_instance_recover_seed_kinematics
<<Instances: sub interfaces>>=
module subroutine process_instance_recover_seed_kinematics &
(instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
end subroutine process_instance_recover_seed_kinematics
<<Instances: procedures>>=
module subroutine process_instance_recover_seed_kinematics (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
type(vector4_t), dimension(:), allocatable :: p_seed_ref
integer :: i
if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
call instance%term(i_term)%recover_seed_kinematics (instance%kin(i_term))
if (instance%term(i_term)%nlo_type == NLO_REAL) then
allocate (p_seed_ref &
(instance%term(i_term)%isolated%int_eff%get_n_out ()))
p_seed_ref = instance%term(i_term)%isolated%int_eff%get_momenta &
(outgoing = .true.)
do i = 1, size (instance%term)
if (i /= i_term .and. instance%term(i)%nlo_type == NLO_REAL) then
if (instance%term(i)%active) then
call instance%term(i)%recover_seed_kinematics &
(instance%kin(i), p_seed_ref)
end if
end if
end do
end if
end if
end subroutine process_instance_recover_seed_kinematics
@ %def process_instance_recover_seed_kinematics
@ Third step of process evaluation: compute the effective momentum
configurations, for all active terms, from the hard kinematics.
<<Instances: process instance: TBP>>=
procedure :: compute_eff_kinematics => &
process_instance_compute_eff_kinematics
<<Instances: sub interfaces>>=
module subroutine process_instance_compute_eff_kinematics &
(instance, skip_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in), optional :: skip_term
end subroutine process_instance_compute_eff_kinematics
<<Instances: procedures>>=
module subroutine process_instance_compute_eff_kinematics &
(instance, skip_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in), optional :: skip_term
integer :: i
if (instance%evaluation_status >= STAT_HARD_KINEMATICS) then
do i = 1, size (instance%term)
if (present (skip_term)) then
if (i == skip_term) cycle
end if
if (instance%term(i)%active) then
call instance%term(i)%compute_eff_kinematics ()
end if
end do
instance%evaluation_status = STAT_EFF_KINEMATICS
end if
end subroutine process_instance_compute_eff_kinematics
@ %def process_instance_setup_compute_eff_kinematics
@ Inverse: recover the hard kinematics from effective kinematics for
one term, then compute effective kinematics for the other terms.
<<Instances: process instance: TBP>>=
procedure :: recover_hard_kinematics => &
process_instance_recover_hard_kinematics
<<Instances: sub interfaces>>=
module subroutine process_instance_recover_hard_kinematics &
(instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
end subroutine process_instance_recover_hard_kinematics
<<Instances: procedures>>=
module subroutine process_instance_recover_hard_kinematics (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
integer :: i
if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
call instance%term(i_term)%recover_hard_kinematics ()
do i = 1, size (instance%term)
if (i /= i_term) then
if (instance%term(i)%active) then
call instance%term(i)%compute_eff_kinematics ()
end if
end if
end do
instance%evaluation_status = STAT_EFF_KINEMATICS
end if
end subroutine process_instance_recover_hard_kinematics
@ %def recover_hard_kinematics
@ Fourth step of process evaluation: check cuts for all terms. Where
successful, compute any scales and weights. Otherwise, deactive the term.
If any of the terms has passed, set the state to [[STAT_PASSED_CUTS]].
The argument [[scale_forced]], if present, will override the scale calculation
in the term expressions.
<<Instances: process instance: TBP>>=
procedure :: evaluate_expressions => &
process_instance_evaluate_expressions
<<Instances: sub interfaces>>=
module subroutine process_instance_evaluate_expressions &
(instance, scale_forced)
class(process_instance_t), intent(inout) :: instance
real(default), intent(in), allocatable, optional :: scale_forced
end subroutine process_instance_evaluate_expressions
<<Instances: procedures>>=
module subroutine process_instance_evaluate_expressions &
(instance, scale_forced)
class(process_instance_t), intent(inout) :: instance
real(default), intent(in), allocatable, optional :: scale_forced
integer :: i
logical :: passed_real
if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
do i = 1, size (instance%term)
if (instance%term(i)%active) then
call instance%term(i)%evaluate_expressions &
(instance%process%get_beam_config (), scale_forced)
end if
end do
call evaluate_real_scales_and_cuts ()
call set_ellis_sexton_scale ()
if (.not. passed_real) then
instance%evaluation_status = STAT_FAILED_CUTS
else
if (any (instance%term%passed)) then
instance%evaluation_status = STAT_PASSED_CUTS
else
instance%evaluation_status = STAT_FAILED_CUTS
end if
end if
end if
contains
subroutine evaluate_real_scales_and_cuts ()
integer :: i
passed_real = .true.
select type (pcm => instance%pcm)
type is (pcm_nlo_t)
do i = 1, size (instance%term)
if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_REAL) then
if (pcm%settings%cut_all_real_sqmes) &
passed_real = passed_real .and. instance%term(i)%passed
if (pcm%settings%use_born_scale) &
call replace_scales (instance%term(i))
end if
end do
end select
end subroutine evaluate_real_scales_and_cuts
subroutine replace_scales (this_term)
type(term_instance_t), intent(inout) :: this_term
integer :: i_sub
i_sub = this_term%config%i_sub
if (this_term%config%i_term_global /= i_sub .and. i_sub > 0) then
this_term%ren_scale = instance%term(i_sub)%ren_scale
this_term%fac_scale = instance%term(i_sub)%fac_scale
end if
end subroutine replace_scales
subroutine set_ellis_sexton_scale ()
real(default) :: es_scale
type(var_list_t), pointer :: var_list
integer :: i
var_list => instance%process%get_var_list_ptr ()
es_scale = var_list%get_rval (var_str ("ellis_sexton_scale"))
do i = 1, size (instance%term)
if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_VIRTUAL) then
if (es_scale > zero) then
if (allocated (instance%term(i)%es_scale)) then
instance%term(i)%es_scale = es_scale
else
allocate (instance%term(i)%es_scale, source=es_scale)
end if
end if
end if
end do
end subroutine set_ellis_sexton_scale
end subroutine process_instance_evaluate_expressions
@ %def process_instance_evaluate_expressions
@ Fifth step of process evaluation: fill the parameters for the non-selected
channels, that have not been used for seeding. We should do this after
evaluating cuts, since we may save some expensive calculations if the phase
space point fails the cuts.
If [[skip_term]] is set, we skip the component that accesses this
term. We can assume that the associated data have already been
recovered, and we are just computing the rest.
<<Instances: process instance: TBP>>=
procedure :: compute_other_channels => &
process_instance_compute_other_channels
<<Instances: sub interfaces>>=
module subroutine process_instance_compute_other_channels &
(instance, skip_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in), optional :: skip_term
end subroutine process_instance_compute_other_channels
<<Instances: procedures>>=
module subroutine process_instance_compute_other_channels &
(instance, skip_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in), optional :: skip_term
integer :: channel, skip_component, i, j
integer, dimension(:), allocatable :: i_term
channel = instance%selected_channel
if (channel == 0) then
call msg_bug ("Compute other channels: undefined integration channel")
end if
if (present (skip_term)) then
skip_component = instance%term(skip_term)%config%i_component
else
skip_component = 0
end if
if (instance%evaluation_status >= STAT_PASSED_CUTS) then
do i = 1, instance%process%get_n_components ()
if (i == skip_component) cycle
if (instance%process%component_is_selected (i)) then
allocate (i_term (size (instance%process%get_component_i_terms (i))))
i_term = instance%process%get_component_i_terms (i)
do j = 1, size (i_term)
call instance%kin(i_term(j))%compute_other_channels &
(instance%mci_work(instance%i_mci), channel)
end do
end if
if (allocated (i_term)) deallocate (i_term)
end do
end if
end subroutine process_instance_compute_other_channels
@ %def process_instance_compute_other_channels
@ If not done otherwise, we flag the kinematics as new for the core state,
such that the routine below will actually compute the matrix element and not
just look it up.
<<Instances: process instance: TBP>>=
procedure :: reset_core_kinematics => process_instance_reset_core_kinematics
<<Instances: sub interfaces>>=
module subroutine process_instance_reset_core_kinematics (instance)
class(process_instance_t), intent(inout) :: instance
end subroutine process_instance_reset_core_kinematics
<<Instances: procedures>>=
module subroutine process_instance_reset_core_kinematics (instance)
class(process_instance_t), intent(inout) :: instance
integer :: i
if (instance%evaluation_status >= STAT_PASSED_CUTS) then
do i = 1, size (instance%term)
associate (term => instance%term(i))
if (term%active .and. term%passed) then
if (allocated (term%core_state)) &
call term%core_state%reset_new_kinematics ()
end if
end associate
end do
end if
end subroutine process_instance_reset_core_kinematics
@ %def process_instance_reset_core_kinematics
@ Sixth step of process evaluation: evaluate the matrix elements, and compute
the trace (summed over quantum numbers) for all terms. Finally, sum up the
terms, iterating over all active process components.
<<Instances: process instance: TBP>>=
procedure :: evaluate_trace => process_instance_evaluate_trace
<<Instances: sub interfaces>>=
module subroutine process_instance_evaluate_trace (instance, recover)
class(process_instance_t), intent(inout) :: instance
logical, intent(in), optional :: recover
end subroutine process_instance_evaluate_trace
<<Instances: procedures>>=
module subroutine process_instance_evaluate_trace (instance, recover)
class(process_instance_t), intent(inout) :: instance
logical, intent(in), optional :: recover
class(prc_core_t), pointer :: core => null ()
integer :: i, i_real_fin, i_core, i_qn, i_flv
real(default) :: alpha_s, alpha_qed, pt
class(prc_core_t), pointer :: core_sub => null ()
class(model_data_t), pointer :: model => null ()
logical :: has_pdfs
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_evaluate_trace")
has_pdfs = instance%process%pcm_contains_pdfs ()
instance%sqme = zero
select type (pcm_work => instance%pcm_work)
type is (pcm_nlo_workspace_t)
if (allocated(pcm_work%real_sub%sqme_real_arr)) then
pcm_work%real_sub%sqme_real_arr = zero
end if
end select
call instance%reset_matrix_elements ()
if (instance%evaluation_status >= STAT_PASSED_CUTS) then
do i = 1, size (instance%term)
associate (term => instance%term(i), kin => instance%kin(i))
if (term%active .and. term%passed) then
core => instance%process%get_core_term (i)
select type (pcm => instance%process%get_pcm_ptr ())
class is (pcm_nlo_t)
i_core = pcm%get_i_core (pcm%i_sub)
core_sub => instance%process%get_core_ptr (i_core)
end select
call term%evaluate_interaction (core, kin)
call term%evaluate_trace (kin)
i_real_fin = instance%process%get_associated_real_fin (1)
if (instance%process%uses_real_partition ()) &
call term%apply_real_partition (kin)
if (term%config%i_component == i_real_fin) then
if (term%nlo_type == NLO_REAL .and. .not. term%is_subtraction ()) then
!!! Force the scale pT into the events for the real finite
associate (p_hard => term%p_hard)
!!! This is only the correct pt for ISR
pt = transverse_part(p_hard(size(p_hard)))
call term%set_fac_scale (pt)
select type (core)
class is (prc_external_t)
select type (core_state => term%core_state)
class is (prc_external_state_t)
core_state%alpha_qcd = core%qcd%alpha%get (pt)
end select
type is (prc_omega_t)
select type (core_state => term%core_state)
type is (omega_state_t)
core_state%alpha_qcd = core%qcd%alpha%get (pt)
end select
end select
end associate
end if
else
if (term%nlo_type == BORN) then
do i_flv = 1, term%connected%trace%get_qn_index_n_flv ()
i_qn = term%connected%trace%get_qn_index (i_flv, i_sub = 0)
if (.not. term%passed_array(i_flv)) then
call term%connected%trace%set_matrix_element &
(i_qn, cmplx (zero, zero, default))
end if
end do
end if
if ((term%nlo_type == NLO_REAL .and. kin%emitter < 0) &
.or. term%nlo_type == NLO_MISMATCH &
.or. term%nlo_type == NLO_DGLAP) &
call term%set_born_sqmes (core)
if (term%is_subtraction () .or. &
term%nlo_type == NLO_DGLAP) &
call term%set_sf_factors (kin, has_pdfs)
if (term%nlo_type > BORN) then
if (.not. (term%nlo_type == NLO_REAL .and. &
kin%emitter >= 0)) then
select type (pcm => term%pcm)
type is (pcm_nlo_t)
if (char (pcm%settings%nlo_correction_type) == "QCD" .or. &
char (pcm%settings%nlo_correction_type) == "Full") &
call term%evaluate_color_correlations (core_sub)
if (char (pcm%settings%nlo_correction_type) == "EW" .or. &
char (pcm%settings%nlo_correction_type) == "Full") then
call term%evaluate_charge_correlations (core_sub)
select type (pcm => term%pcm)
type is (pcm_nlo_t)
associate (reg_data => pcm%region_data)
if (reg_data%alphas_power > 0) &
call term%evaluate_color_correlations (core_sub)
end associate
end select
end if
end select
end if
if (term%is_subtraction ()) then
call term%evaluate_spin_correlations (core_sub)
end if
end if
alpha_s = core%get_alpha_s (term%core_state)
alpha_qed = core%get_alpha_qed (term%core_state)
if (term%nlo_type > BORN) then
select type (pcm => term%pcm)
type is (pcm_nlo_t)
if (alpha_qed == -1 .and. (&
char (pcm%settings%nlo_correction_type) == "EW" .or. &
char (pcm%settings%nlo_correction_type) == "Full")) then
call msg_bug("Attempting to compute EW corrections with alpha_qed = -1")
end if
end select
end if
if (present (recover)) then
if (recover) return
end if
select case (term%nlo_type)
case (NLO_REAL)
call term%apply_fks (kin, alpha_s, alpha_qed)
case (NLO_VIRTUAL)
call term%evaluate_sqme_virt (alpha_s, alpha_qed)
case (NLO_MISMATCH)
call term%evaluate_sqme_mismatch (alpha_s)
case (NLO_DGLAP)
call term%evaluate_sqme_dglap (alpha_s, alpha_qed)
end select
end if
end if
core_sub => null ()
instance%sqme = instance%sqme + real (sum (&
term%connected%trace%get_matrix_element () * &
term%weight))
end associate
end do
core => null ()
if (instance%pcm_work%is_valid ()) then
instance%evaluation_status = STAT_EVALUATED_TRACE
else
instance%evaluation_status = STAT_FAILED_KINEMATICS
end if
else
!!! Failed kinematics or failed cuts: set sqme to zero
instance%sqme = zero
end if
end subroutine process_instance_evaluate_trace
@ %def process_instance_evaluate_trace
<<Instances: term instance: TBP>>=
procedure :: set_born_sqmes => term_instance_set_born_sqmes
<<Instances: sub interfaces>>=
module subroutine term_instance_set_born_sqmes (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(in) :: core
end subroutine term_instance_set_born_sqmes
<<Instances: procedures>>=
module subroutine term_instance_set_born_sqmes (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(in) :: core
integer :: i_flv, ii_flv
real(default) :: sqme
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
do i_flv = 1, term%connected%trace%get_qn_index_n_flv ()
ii_flv = term%connected%trace%get_qn_index (i_flv, i_sub = 0)
if (term%passed_array (i_flv) .or. .not. term%passed) then
sqme = real (term%connected%trace%get_matrix_element (ii_flv))
else
sqme = zero
end if
select case (term%nlo_type)
case (NLO_REAL)
pcm_work%real_sub%sqme_born(i_flv) = sqme
case (NLO_MISMATCH)
pcm_work%soft_mismatch%sqme_born(i_flv) = sqme
case (NLO_DGLAP)
pcm_work%dglap_remnant%sqme_born(i_flv) = sqme
end select
end do
end select
end subroutine term_instance_set_born_sqmes
@ %def term_instance_set_born_sqmes
@ Calculates and then saves the ratio of the value of the (rescaled) real
structure function chain of each ISR alpha region over the value of the
corresponding underlying born flavor structure. In the case of emitter
0 we also need the rescaled ratio for emitter 1 and 2 in that region
for the (soft-)collinear limits. If the emitter is 1 or 2 in some
cases, e. g. for EW corrections where a photon in the proton is
required, there can be the possibility of soft radiation off the
initial state. For that purpose the unrescaled ratio is needed and as
a default we always save these numbers in [[sf_factors(:,0)]]. Although
this procedure is implying functionality for general structure functions,
it should be reviewed for anything else besides PDFs, as there might
be complications in the details. The general idea of getting the ratio
in this way should hold up in these cases as well, however.
<<Instances: term instance: TBP>>=
procedure :: set_sf_factors => term_instance_set_sf_factors
<<Instances: sub interfaces>>=
module subroutine term_instance_set_sf_factors (term, kin, has_pdfs)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(inout) :: kin
logical, intent(in) :: has_pdfs
end subroutine term_instance_set_sf_factors
<<Instances: procedures>>=
module subroutine term_instance_set_sf_factors (term, kin, has_pdfs)
class(term_instance_t), intent(inout) :: term
type(kinematics_t), intent(inout) :: kin
logical, intent(in) :: has_pdfs
type(interaction_t), pointer :: sf_chain_int
real(default) :: factor_born, factor_real
integer :: n_in, alr, em
integer :: i_born, i_real
select type (pcm_work => term%pcm_work)
type is (pcm_nlo_workspace_t)
if (.not. has_pdfs) then
pcm_work%real_sub%sf_factors = one
return
end if
select type (pcm => term%pcm)
type is (pcm_nlo_t)
sf_chain_int => kin%sf_chain%get_out_int_ptr ()
associate (reg_data => pcm%region_data)
n_in = reg_data%get_n_in ()
do alr = 1, reg_data%n_regions
em = reg_data%regions(alr)%emitter
if (em <= n_in) then
i_born = reg_data%regions(alr)%uborn_index
i_real = reg_data%regions(alr)%real_index
factor_born = sf_chain_int%get_matrix_element &
(sf_chain_int%get_sf_qn_index_born (i_born, i_sub = 0))
factor_real = sf_chain_int%get_matrix_element &
(sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em))
call set_factor (pcm_work, alr, em, factor_born, factor_real)
if (em == 0) then
do em = 1, 2
factor_real = sf_chain_int%get_matrix_element &
(sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em))
call set_factor (pcm_work, alr, em, factor_born, factor_real)
end do
else
factor_real = sf_chain_int%get_matrix_element &
(sf_chain_int%get_sf_qn_index_real (i_real, i_sub = 0))
call set_factor (pcm_work, alr, 0, factor_born, factor_real)
end if
end if
end do
end associate
end select
end select
contains
subroutine set_factor (pcm_work, alr, em, factor_born, factor_real)
type(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
integer, intent(in) :: alr, em
real(default), intent(in) :: factor_born, factor_real
real(default) :: factor
if (any (vanishes ([factor_real, factor_born], tiny(1._default), tiny(1._default)))) then
factor = zero
else
factor = factor_real / factor_born
end if
select case (term%nlo_type)
case (NLO_REAL)
pcm_work%real_sub%sf_factors(alr, em) = factor
case (NLO_DGLAP)
pcm_work%dglap_remnant%sf_factors(alr, em) = factor
end select
end subroutine
end subroutine term_instance_set_sf_factors
@ %def term_instance_set_sf_factors
@
<<Instances: process instance: TBP>>=
procedure :: apply_real_partition => process_instance_apply_real_partition
<<Instances: sub interfaces>>=
module subroutine process_instance_apply_real_partition (instance)
class(process_instance_t), intent(inout) :: instance
end subroutine process_instance_apply_real_partition
<<Instances: procedures>>=
module subroutine process_instance_apply_real_partition (instance)
class(process_instance_t), intent(inout) :: instance
integer :: i_component, i_term
integer, dimension(:), allocatable :: i_terms
associate (process => instance%process)
i_component = process%get_first_real_component ()
if (process%component_is_selected (i_component) .and. &
process%get_component_nlo_type (i_component) == NLO_REAL) then
- allocate (i_terms &
- (size (process%get_component_i_terms (i_component))))
- i_terms = process%get_component_i_terms (i_component)
+ allocate (i_terms, source=process%get_component_i_terms (i_component))
do i_term = 1, size (i_terms)
call instance%term(i_terms(i_term))%apply_real_partition ( &
instance%kin(i_terms(i_term)))
end do
end if
if (allocated (i_terms)) deallocate (i_terms)
end associate
end subroutine process_instance_apply_real_partition
@ %def process_instance_apply_real_partition
@
<<Instances: process instance: TBP>>=
procedure :: set_i_mci_to_real_component => &
process_instance_set_i_mci_to_real_component
<<Instances: sub interfaces>>=
module subroutine process_instance_set_i_mci_to_real_component (instance)
class(process_instance_t), intent(inout) :: instance
end subroutine process_instance_set_i_mci_to_real_component
<<Instances: procedures>>=
module subroutine process_instance_set_i_mci_to_real_component (instance)
class(process_instance_t), intent(inout) :: instance
integer :: i_mci, i_component
type(process_component_t), pointer :: component => null ()
select type (pcm_work => instance%pcm_work)
type is (pcm_nlo_workspace_t)
if (allocated (pcm_work%i_mci_to_real_component)) then
call msg_warning &
("i_mci_to_real_component already allocated - replace it")
deallocate (pcm_work%i_mci_to_real_component)
end if
allocate (pcm_work%i_mci_to_real_component (size (instance%mci_work)))
do i_mci = 1, size (instance%mci_work)
do i_component = 1, instance%process%get_n_components ()
component => instance%process%get_component_ptr (i_component)
if (component%i_mci /= i_mci) cycle
select case (component%component_type)
case (COMP_MASTER, COMP_REAL)
pcm_work%i_mci_to_real_component (i_mci) = &
component%config%get_associated_real ()
case (COMP_REAL_FIN)
pcm_work%i_mci_to_real_component (i_mci) = &
component%config%get_associated_real_fin ()
case (COMP_REAL_SING)
pcm_work%i_mci_to_real_component (i_mci) = &
component%config%get_associated_real_sing ()
end select
end do
end do
component => null ()
end select
end subroutine process_instance_set_i_mci_to_real_component
@ %def process_instance_set_i_mci_to_real_component
@ Final step of process evaluation: evaluate the matrix elements, and compute
the trace (summed over quantum numbers) for all terms. Finally, sum up the
terms, iterating over all active process components.
If [[weight]] is provided, we already know the kinematical event
weight (the MCI weight which depends on the kinematics sampling
algorithm, but not on the matrix element), so we do not need to take
it from the MCI record.
<<Instances: process instance: TBP>>=
procedure :: evaluate_event_data => process_instance_evaluate_event_data
<<Instances: sub interfaces>>=
module subroutine process_instance_evaluate_event_data (instance, weight)
class(process_instance_t), intent(inout) :: instance
real(default), intent(in), optional :: weight
end subroutine process_instance_evaluate_event_data
<<Instances: procedures>>=
module subroutine process_instance_evaluate_event_data (instance, weight)
class(process_instance_t), intent(inout) :: instance
real(default), intent(in), optional :: weight
integer :: i
if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then
do i = 1, size (instance%term)
associate (term => instance%term(i))
if (term%active) then
call term%evaluate_event_data ()
end if
end associate
end do
if (present (weight)) then
instance%weight = weight
else
instance%weight = &
instance%mci_work(instance%i_mci)%mci%get_event_weight ()
instance%excess = &
instance%mci_work(instance%i_mci)%mci%get_event_excess ()
end if
instance%n_dropped = &
instance%mci_work(instance%i_mci)%mci%get_n_event_dropped ()
instance%evaluation_status = STAT_EVENT_COMPLETE
else
!!! failed kinematics etc.: set weight to zero
instance%weight = zero
!!! Maybe we want to process and keep the event nevertheless
if (instance%keep_failed_events ()) then
do i = 1, size (instance%term)
associate (term => instance%term(i))
if (term%active) then
call term%evaluate_event_data ()
end if
end associate
end do
! do i = 1, size (instance%term)
! instance%term(i)%fac_scale = zero
! end do
instance%evaluation_status = STAT_EVENT_COMPLETE
end if
end if
end subroutine process_instance_evaluate_event_data
@ %def process_instance_evaluate_event_data
@ Computes the real-emission matrix element for externally supplied momenta
for the term instance with index [[i_term]] and a phase space point set with
index [[i_phs]]. In addition, for the real emission, each term instance
corresponds to one emitter. There is the possibility to supply an external
$\alpha_s$ as well as an external scale to override the scale set in the
Sindarin, e.g. for POWHEG matching.
<<Instances: process instance: TBP>>=
procedure :: compute_sqme_rad => process_instance_compute_sqme_rad
<<Instances: sub interfaces>>=
module subroutine process_instance_compute_sqme_rad (instance, &
i_term, i_phs, is_subtraction, alpha_s_external, scale_forced)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term, i_phs
logical, intent(in) :: is_subtraction
real(default), intent(in), optional :: alpha_s_external
real(default), intent(in), allocatable, optional :: scale_forced
end subroutine process_instance_compute_sqme_rad
<<Instances: procedures>>=
module subroutine process_instance_compute_sqme_rad (instance, &
i_term, i_phs, is_subtraction, alpha_s_external, scale_forced)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term, i_phs
logical, intent(in) :: is_subtraction
real(default), intent(in), optional :: alpha_s_external
real(default), intent(in), allocatable, optional :: scale_forced
class(prc_core_t), pointer :: core
integer :: i_real_fin
logical :: has_pdfs
has_pdfs = instance%process%pcm_contains_pdfs ()
select type (pcm_work => instance%pcm_work)
type is (pcm_nlo_workspace_t)
if (allocated(pcm_work%real_sub%sqme_real_arr)) then
pcm_work%real_sub%sqme_real_arr = zero
end if
end select
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_compute_sqme_rad")
select type (pcm_work => instance%pcm_work)
type is (pcm_nlo_workspace_t)
associate (term => instance%term(i_term), kin => instance%kin(i_term))
core => instance%process%get_core_term (i_term)
if (is_subtraction) then
call pcm_work%set_subtraction_event ()
else
call pcm_work%set_radiation_event ()
end if
call term%int_hard%set_momenta (pcm_work%get_momenta &
(term%pcm, i_phs = i_phs, born_phsp = is_subtraction))
if (allocated (term%core_state)) &
call term%core_state%reset_new_kinematics ()
if (present (alpha_s_external)) then
call term%set_alpha_qcd_forced (alpha_s_external)
end if
call term%compute_eff_kinematics ()
call term%evaluate_expressions &
(instance%process%get_beam_config (), scale_forced)
call term%evaluate_interaction (core, kin)
call term%evaluate_trace (kin)
if (term%is_subtraction ()) then
call term%set_sf_factors (kin, has_pdfs)
select type (pcm => instance%pcm)
type is (pcm_nlo_t)
if (char (pcm%settings%nlo_correction_type) == "QCD" .or. &
char (pcm%settings%nlo_correction_type) == "Full") &
call term%evaluate_color_correlations (core)
if (char (pcm%settings%nlo_correction_type) == "EW" .or. &
char (pcm%settings%nlo_correction_type) == "Full") &
call term%evaluate_charge_correlations (core)
end select
call term%evaluate_spin_correlations (core)
end if
i_real_fin = instance%process%get_associated_real_fin (1)
if (term%config%i_component /= i_real_fin) &
call term%apply_fks (kin, core%get_alpha_s (term%core_state), &
core%get_alpha_qed (term%core_state))
if (instance%process%uses_real_partition ()) &
call instance%apply_real_partition ()
end associate
end select
core => null ()
end subroutine process_instance_compute_sqme_rad
@ %def process_instance_compute_sqme_rad
@ For unweighted event generation, we should reset the reported event
weight to unity (signed) or zero. The latter case is appropriate for
an event which failed for whatever reason.
<<Instances: process instance: TBP>>=
procedure :: normalize_weight => process_instance_normalize_weight
<<Instances: sub interfaces>>=
module subroutine process_instance_normalize_weight (instance)
class(process_instance_t), intent(inout) :: instance
end subroutine process_instance_normalize_weight
<<Instances: procedures>>=
module subroutine process_instance_normalize_weight (instance)
class(process_instance_t), intent(inout) :: instance
if (.not. vanishes (instance%weight)) then
instance%weight = sign (1._default, instance%weight)
end if
end subroutine process_instance_normalize_weight
@ %def process_instance_normalize_weight
@ This is a convenience routine that performs the computations of the
steps 1 to 5 in a single step. The arguments are the input for
[[set_mcpar]]. After this, the evaluation status should be either
[[STAT_FAILED_KINEMATICS]], [[STAT_FAILED_CUTS]] or [[STAT_EVALUATED_TRACE]].
Before calling this, we should call [[choose_mci]].
<<Instances: process instance: TBP>>=
procedure :: evaluate_sqme => process_instance_evaluate_sqme
<<Instances: sub interfaces>>=
module subroutine process_instance_evaluate_sqme (instance, channel, x)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: channel
real(default), dimension(:), intent(in) :: x
end subroutine process_instance_evaluate_sqme
<<Instances: procedures>>=
module subroutine process_instance_evaluate_sqme (instance, channel, x)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: channel
real(default), dimension(:), intent(in) :: x
call instance%reset ()
call instance%set_mcpar (x)
call instance%select_channel (channel)
call instance%compute_seed_kinematics ()
call instance%compute_hard_kinematics ()
call instance%compute_eff_kinematics ()
call instance%evaluate_expressions ()
call instance%compute_other_channels ()
call instance%evaluate_trace ()
end subroutine process_instance_evaluate_sqme
@ %def process_instance_evaluate_sqme
@ This is the inverse. Assuming that the final trace evaluator
contains a valid momentum configuration, recover kinematics
and recalculate the matrix elements and their trace.
To be precise, we first recover kinematics for the given term and
associated component, then recalculate from that all other terms and
active components. The [[channel]] is not really required to obtain
the matrix element, but it allows us to reconstruct the exact MC
parameter set that corresponds to the given phase space point.
Before calling this, we should call [[choose_mci]].
<<Instances: process instance: TBP>>=
procedure :: recover => process_instance_recover
<<Instances: sub interfaces>>=
module subroutine process_instance_recover &
(instance, channel, i_term, update_sqme, recover_phs, scale_forced)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: channel
integer, intent(in) :: i_term
logical, intent(in) :: update_sqme
logical, intent(in) :: recover_phs
real(default), intent(in), allocatable, optional :: scale_forced
end subroutine process_instance_recover
<<Instances: procedures>>=
module subroutine process_instance_recover &
(instance, channel, i_term, update_sqme, recover_phs, scale_forced)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: channel
integer, intent(in) :: i_term
logical, intent(in) :: update_sqme
logical, intent(in) :: recover_phs
real(default), intent(in), allocatable, optional :: scale_forced
logical :: skip_phs, recover
call instance%activate ()
instance%evaluation_status = STAT_EFF_KINEMATICS
call instance%recover_hard_kinematics (i_term)
call instance%recover_seed_kinematics (i_term)
call instance%select_channel (channel)
recover = instance%pcm_work%is_nlo ()
if (recover_phs) then
call instance%recover_mcpar (i_term)
call instance%recover_beam_momenta (i_term)
call instance%compute_seed_kinematics &
(recover = recover, skip_term = i_term)
call instance%compute_hard_kinematics &
(recover = recover, skip_term = i_term)
call instance%compute_eff_kinematics (i_term)
call instance%compute_other_channels (i_term)
else
call instance%recover_sfchain (i_term)
end if
call instance%evaluate_expressions (scale_forced)
if (update_sqme) then
call instance%reset_core_kinematics ()
call instance%evaluate_trace (recover)
end if
end subroutine process_instance_recover
@ %def process_instance_recover
@ The [[evaluate]] method is required by the [[sampler_t]] base type of which
the process instance is an extension.
The requirement is that after the process instance is evaluated, the
integrand, the selected channel, the $x$ array, and the $f$ Jacobian array are
exposed by the [[sampler_t]] object.
We allow for the additional [[hook]] to be called, if associated, for outlying
object to access information from the current state of the [[sampler]].
<<Instances: process instance: TBP>>=
procedure :: evaluate => process_instance_evaluate
<<Instances: sub interfaces>>=
module subroutine process_instance_evaluate (sampler, c, x_in, val, x, f)
class(process_instance_t), intent(inout) :: sampler
integer, intent(in) :: c
real(default), dimension(:), intent(in) :: x_in
real(default), intent(out) :: val
real(default), dimension(:,:), intent(out) :: x
real(default), dimension(:), intent(out) :: f
end subroutine process_instance_evaluate
<<Instances: procedures>>=
module subroutine process_instance_evaluate (sampler, c, x_in, val, x, f)
class(process_instance_t), intent(inout) :: sampler
integer, intent(in) :: c
real(default), dimension(:), intent(in) :: x_in
real(default), intent(out) :: val
real(default), dimension(:,:), intent(out) :: x
real(default), dimension(:), intent(out) :: f
call sampler%evaluate_sqme (c, x_in)
if (sampler%is_valid ()) then
call sampler%fetch (val, x, f)
end if
call sampler%record_call ()
call sampler%evaluate_after_hook ()
end subroutine process_instance_evaluate
@ %def process_instance_evaluate
@ The phase-space point is valid if the event has valid kinematics and
has passed the cuts.
<<Instances: process instance: TBP>>=
procedure :: is_valid => process_instance_is_valid
<<Instances: sub interfaces>>=
module function process_instance_is_valid (sampler) result (valid)
class(process_instance_t), intent(in) :: sampler
logical :: valid
end function process_instance_is_valid
<<Instances: procedures>>=
module function process_instance_is_valid (sampler) result (valid)
class(process_instance_t), intent(in) :: sampler
logical :: valid
valid = sampler%evaluation_status >= STAT_PASSED_CUTS
end function process_instance_is_valid
@ %def process_instance_is_valid
@ Add a [[process_instance_hook]] object..
<<Instances: process instance: TBP>>=
procedure :: append_after_hook => process_instance_append_after_hook
<<Instances: sub interfaces>>=
module subroutine process_instance_append_after_hook (sampler, new_hook)
class(process_instance_t), intent(inout), target :: sampler
class(process_instance_hook_t), intent(inout), target :: new_hook
end subroutine process_instance_append_after_hook
<<Instances: procedures>>=
module subroutine process_instance_append_after_hook (sampler, new_hook)
class(process_instance_t), intent(inout), target :: sampler
class(process_instance_hook_t), intent(inout), target :: new_hook
class(process_instance_hook_t), pointer :: last
if (associated (new_hook%next)) then
call msg_bug ("process_instance_append_after_hook: " // &
"reuse of SAME hook object is forbidden.")
end if
if (associated (sampler%hook)) then
last => sampler%hook
do while (associated (last%next))
last => last%next
end do
last%next => new_hook
else
sampler%hook => new_hook
end if
end subroutine process_instance_append_after_hook
@ %def process_instance_append_after_evaluate_hook
@ Evaluate the after hook as first in, last out.
<<Instances: process instance: TBP>>=
procedure :: evaluate_after_hook => process_instance_evaluate_after_hook
<<Instances: sub interfaces>>=
module subroutine process_instance_evaluate_after_hook (sampler)
class(process_instance_t), intent(in) :: sampler
end subroutine process_instance_evaluate_after_hook
<<Instances: procedures>>=
module subroutine process_instance_evaluate_after_hook (sampler)
class(process_instance_t), intent(in) :: sampler
class(process_instance_hook_t), pointer :: current
current => sampler%hook
do while (associated(current))
call current%evaluate (sampler)
current => current%next
end do
end subroutine process_instance_evaluate_after_hook
@ %def process_instance_evaluate_after_hook
@ The [[rebuild]] method should rebuild the kinematics section out of
the [[x_in]] parameter set. The integrand value [[val]] should not be
computed, but is provided as input.
<<Instances: process instance: TBP>>=
procedure :: rebuild => process_instance_rebuild
<<Instances: sub interfaces>>=
module subroutine process_instance_rebuild (sampler, c, x_in, val, x, f)
class(process_instance_t), intent(inout) :: sampler
integer, intent(in) :: c
real(default), dimension(:), intent(in) :: x_in
real(default), intent(in) :: val
real(default), dimension(:,:), intent(out) :: x
real(default), dimension(:), intent(out) :: f
end subroutine process_instance_rebuild
<<Instances: procedures>>=
module subroutine process_instance_rebuild (sampler, c, x_in, val, x, f)
class(process_instance_t), intent(inout) :: sampler
integer, intent(in) :: c
real(default), dimension(:), intent(in) :: x_in
real(default), intent(in) :: val
real(default), dimension(:,:), intent(out) :: x
real(default), dimension(:), intent(out) :: f
call msg_bug ("process_instance_rebuild not implemented yet")
x = 0
f = 0
end subroutine process_instance_rebuild
@ %def process_instance_rebuild
@ This is another method required by the [[sampler_t]] base type:
fetch the data that are relevant for the MCI record.
<<Instances: process instance: TBP>>=
procedure :: fetch => process_instance_fetch
<<Instances: sub interfaces>>=
module subroutine process_instance_fetch (sampler, val, x, f)
class(process_instance_t), intent(in) :: sampler
real(default), intent(out) :: val
real(default), dimension(:,:), intent(out) :: x
real(default), dimension(:), intent(out) :: f
end subroutine process_instance_fetch
<<Instances: procedures>>=
module subroutine process_instance_fetch (sampler, val, x, f)
class(process_instance_t), intent(in) :: sampler
real(default), intent(out) :: val
real(default), dimension(:,:), intent(out) :: x
real(default), dimension(:), intent(out) :: f
integer, dimension(:), allocatable :: i_terms
integer :: i, i_term_base, cc
integer :: n_channel
val = 0
associate (process => sampler%process)
FIND_COMPONENT: do i = 1, process%get_n_components ()
if (sampler%process%component_is_selected (i)) then
allocate (i_terms (size (process%get_component_i_terms (i))))
i_terms = process%get_component_i_terms (i)
i_term_base = i_terms(1)
associate (k => sampler%kin(i_term_base))
n_channel = k%n_channel
do cc = 1, n_channel
call k%get_mcpar (cc, x(:,cc))
end do
f = k%f
val = sampler%sqme * k%phs_factor
end associate
if (allocated (i_terms)) deallocate (i_terms)
exit FIND_COMPONENT
end if
end do FIND_COMPONENT
end associate
end subroutine process_instance_fetch
@ %def process_instance_fetch
@ Initialize and finalize event generation for the specified MCI
entry.
<<Instances: process instance: TBP>>=
procedure :: init_simulation => process_instance_init_simulation
procedure :: final_simulation => process_instance_final_simulation
<<Instances: sub interfaces>>=
module subroutine process_instance_init_simulation (instance, i_mci, &
safety_factor, keep_failed_events)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
real(default), intent(in), optional :: safety_factor
logical, intent(in), optional :: keep_failed_events
end subroutine process_instance_init_simulation
module subroutine process_instance_final_simulation (instance, i_mci)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
end subroutine process_instance_final_simulation
<<Instances: procedures>>=
module subroutine process_instance_init_simulation (instance, i_mci, &
safety_factor, keep_failed_events)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
real(default), intent(in), optional :: safety_factor
logical, intent(in), optional :: keep_failed_events
call instance%mci_work(i_mci)%init_simulation &
(safety_factor, keep_failed_events)
end subroutine process_instance_init_simulation
module subroutine process_instance_final_simulation (instance, i_mci)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
call instance%mci_work(i_mci)%final_simulation ()
end subroutine process_instance_final_simulation
@ %def process_instance_init_simulation
@ %def process_instance_final_simulation
@
\subsubsection{Accessing the process instance}
Once the seed kinematics is complete, we can retrieve the MC input parameters
for all channels, not just the seed channel.
Note: We choose the first active component. This makes sense only if the seed
kinematics is identical for all active components.
<<Instances: process instance: TBP>>=
procedure :: get_mcpar => process_instance_get_mcpar
<<Instances: sub interfaces>>=
module subroutine process_instance_get_mcpar (instance, channel, x)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: channel
real(default), dimension(:), intent(out) :: x
end subroutine process_instance_get_mcpar
<<Instances: procedures>>=
module subroutine process_instance_get_mcpar (instance, channel, x)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: channel
real(default), dimension(:), intent(out) :: x
integer :: i
if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then
do i = 1, size (instance%term)
if (instance%term(i)%active) then
call instance%kin(i)%get_mcpar (channel, x)
return
end if
end do
call msg_bug ("Process instance: get_mcpar: no active channels")
else
call msg_bug ("Process instance: get_mcpar: no seed kinematics")
end if
end subroutine process_instance_get_mcpar
@ %def process_instance_get_mcpar
@ Return true if the [[sqme]] value is known. This also implies that the
event is kinematically valid and has passed all cuts.
<<Instances: process instance: TBP>>=
procedure :: has_evaluated_trace => process_instance_has_evaluated_trace
<<Instances: sub interfaces>>=
module function process_instance_has_evaluated_trace &
(instance) result (flag)
class(process_instance_t), intent(in) :: instance
logical :: flag
end function process_instance_has_evaluated_trace
<<Instances: procedures>>=
module function process_instance_has_evaluated_trace (instance) result (flag)
class(process_instance_t), intent(in) :: instance
logical :: flag
flag = instance%evaluation_status >= STAT_EVALUATED_TRACE
end function process_instance_has_evaluated_trace
@ %def process_instance_has_evaluated_trace
@ Return true if the event is complete. In particular, the event must
be kinematically valid, passed all cuts, and the event data have been
computed.
<<Instances: process instance: TBP>>=
procedure :: is_complete_event => process_instance_is_complete_event
<<Instances: sub interfaces>>=
module function process_instance_is_complete_event (instance) result (flag)
class(process_instance_t), intent(in) :: instance
logical :: flag
end function process_instance_is_complete_event
<<Instances: procedures>>=
module function process_instance_is_complete_event (instance) result (flag)
class(process_instance_t), intent(in) :: instance
logical :: flag
flag = instance%evaluation_status >= STAT_EVENT_COMPLETE
end function process_instance_is_complete_event
@ %def process_instance_is_complete_event
@ Select the term for the process instance that will provide the basic
event record (used in [[evt_trivial_make_particle_set]]). It might be
necessary to write out additional events corresponding to other terms
(done in [[evt_nlo]]).
<<Instances: process instance: TBP>>=
procedure :: select_i_term => process_instance_select_i_term
<<Instances: sub interfaces>>=
module function process_instance_select_i_term (instance) result (i_term)
integer :: i_term
class(process_instance_t), intent(in) :: instance
end function process_instance_select_i_term
<<Instances: procedures>>=
module function process_instance_select_i_term (instance) result (i_term)
integer :: i_term
class(process_instance_t), intent(in) :: instance
integer :: i_mci
i_mci = instance%i_mci
i_term = instance%process%select_i_term (i_mci)
end function process_instance_select_i_term
@ %def process_instance_select_i_term
@ Return pointer to the master beam interaction.
<<Instances: process instance: TBP>>=
procedure :: get_beam_int_ptr => process_instance_get_beam_int_ptr
<<Instances: sub interfaces>>=
module function process_instance_get_beam_int_ptr (instance) result (ptr)
class(process_instance_t), intent(in), target :: instance
type(interaction_t), pointer :: ptr
end function process_instance_get_beam_int_ptr
<<Instances: procedures>>=
module function process_instance_get_beam_int_ptr (instance) result (ptr)
class(process_instance_t), intent(in), target :: instance
type(interaction_t), pointer :: ptr
ptr => instance%sf_chain%get_beam_int_ptr ()
end function process_instance_get_beam_int_ptr
@ %def process_instance_get_beam_int_ptr
@ Return pointers to the matrix and flows interactions, given a term index.
<<Instances: process instance: TBP>>=
procedure :: get_trace_int_ptr => process_instance_get_trace_int_ptr
procedure :: get_matrix_int_ptr => process_instance_get_matrix_int_ptr
procedure :: get_flows_int_ptr => process_instance_get_flows_int_ptr
<<Instances: sub interfaces>>=
module function process_instance_get_trace_int_ptr &
(instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(interaction_t), pointer :: ptr
end function process_instance_get_trace_int_ptr
module function process_instance_get_matrix_int_ptr &
(instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(interaction_t), pointer :: ptr
end function process_instance_get_matrix_int_ptr
module function process_instance_get_flows_int_ptr &
(instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(interaction_t), pointer :: ptr
end function process_instance_get_flows_int_ptr
<<Instances: procedures>>=
module function process_instance_get_trace_int_ptr &
(instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(interaction_t), pointer :: ptr
ptr => instance%term(i_term)%connected%get_trace_int_ptr ()
end function process_instance_get_trace_int_ptr
module function process_instance_get_matrix_int_ptr &
(instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(interaction_t), pointer :: ptr
ptr => instance%term(i_term)%connected%get_matrix_int_ptr ()
end function process_instance_get_matrix_int_ptr
module function process_instance_get_flows_int_ptr &
(instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(interaction_t), pointer :: ptr
ptr => instance%term(i_term)%connected%get_flows_int_ptr ()
end function process_instance_get_flows_int_ptr
@ %def process_instance_get_trace_int_ptr
@ %def process_instance_get_matrix_int_ptr
@ %def process_instance_get_flows_int_ptr
@ Return the complete account of flavor combinations in the underlying
interaction object, including beams, radiation, and hard interaction.
<<Instances: process instance: TBP>>=
procedure :: get_state_flv => process_instance_get_state_flv
<<Instances: sub interfaces>>=
module function process_instance_get_state_flv &
(instance, i_term) result (state_flv)
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
type(state_flv_content_t) :: state_flv
end function process_instance_get_state_flv
<<Instances: procedures>>=
module function process_instance_get_state_flv &
(instance, i_term) result (state_flv)
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
type(state_flv_content_t) :: state_flv
state_flv = instance%term(i_term)%connected%get_state_flv ()
end function process_instance_get_state_flv
@ %def process_instance_get_state_flv
@ Return pointers to the parton states of a selected term.
<<Instances: process instance: TBP>>=
procedure :: get_isolated_state_ptr => &
process_instance_get_isolated_state_ptr
procedure :: get_connected_state_ptr => &
process_instance_get_connected_state_ptr
<<Instances: sub interfaces>>=
module function process_instance_get_isolated_state_ptr &
(instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(isolated_state_t), pointer :: ptr
end function process_instance_get_isolated_state_ptr
module function process_instance_get_connected_state_ptr &
(instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(connected_state_t), pointer :: ptr
end function process_instance_get_connected_state_ptr
<<Instances: procedures>>=
module function process_instance_get_isolated_state_ptr &
(instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(isolated_state_t), pointer :: ptr
ptr => instance%term(i_term)%isolated
end function process_instance_get_isolated_state_ptr
module function process_instance_get_connected_state_ptr &
(instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(connected_state_t), pointer :: ptr
ptr => instance%term(i_term)%connected
end function process_instance_get_connected_state_ptr
@ %def process_instance_get_isolated_state_ptr
@ %def process_instance_get_connected_state_ptr
@ Return the indices of the beam particles and incoming partons within the
currently active state matrix, respectively.
<<Instances: process instance: TBP>>=
procedure :: get_beam_index => process_instance_get_beam_index
procedure :: get_in_index => process_instance_get_in_index
<<Instances: sub interfaces>>=
module subroutine process_instance_get_beam_index (instance, i_term, i_beam)
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
integer, dimension(:), intent(out) :: i_beam
end subroutine process_instance_get_beam_index
module subroutine process_instance_get_in_index (instance, i_term, i_in)
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
integer, dimension(:), intent(out) :: i_in
end subroutine process_instance_get_in_index
<<Instances: procedures>>=
module subroutine process_instance_get_beam_index (instance, i_term, i_beam)
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
integer, dimension(:), intent(out) :: i_beam
call instance%term(i_term)%connected%get_beam_index (i_beam)
end subroutine process_instance_get_beam_index
module subroutine process_instance_get_in_index (instance, i_term, i_in)
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
integer, dimension(:), intent(out) :: i_in
call instance%term(i_term)%connected%get_in_index (i_in)
end subroutine process_instance_get_in_index
@ %def process_instance_get_beam_index
@ %def process_instance_get_in_index
@ Return squared matrix element and event weight, and event weight
excess where applicable. [[n_dropped]] is a number that can be
nonzero when a weighted event has been generated, dropping events with
zero weight (failed cuts) on the fly.
If [[i_term]] is provided for [[get_sqme]], we take the first matrix
element as we also set the first matrix element with [[set_only_matrix_element]]
when computing the real, the dglap or the virtual contribution.
<<Instances: process instance: TBP>>=
procedure :: get_sqme => process_instance_get_sqme
procedure :: get_weight => process_instance_get_weight
procedure :: get_excess => process_instance_get_excess
procedure :: get_n_dropped => process_instance_get_n_dropped
<<Instances: sub interfaces>>=
module function process_instance_get_sqme (instance, i_term) result (sqme)
real(default) :: sqme
class(process_instance_t), intent(in) :: instance
integer, intent(in), optional :: i_term
end function process_instance_get_sqme
module function process_instance_get_weight (instance) result (weight)
real(default) :: weight
class(process_instance_t), intent(in) :: instance
end function process_instance_get_weight
module function process_instance_get_excess (instance) result (excess)
real(default) :: excess
class(process_instance_t), intent(in) :: instance
end function process_instance_get_excess
module function process_instance_get_n_dropped (instance) result (n_dropped)
integer :: n_dropped
class(process_instance_t), intent(in) :: instance
end function process_instance_get_n_dropped
<<Instances: procedures>>=
module function process_instance_get_sqme (instance, i_term) result (sqme)
real(default) :: sqme
class(process_instance_t), intent(in) :: instance
integer, intent(in), optional :: i_term
if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then
if (present (i_term)) then
sqme = instance%term(i_term)%connected%trace%get_matrix_element (1)
else
sqme = instance%sqme
end if
else
sqme = 0
end if
end function process_instance_get_sqme
module function process_instance_get_weight (instance) result (weight)
real(default) :: weight
class(process_instance_t), intent(in) :: instance
if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
weight = instance%weight
else
weight = 0
end if
end function process_instance_get_weight
module function process_instance_get_excess (instance) result (excess)
real(default) :: excess
class(process_instance_t), intent(in) :: instance
if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
excess = instance%excess
else
excess = 0
end if
end function process_instance_get_excess
module function process_instance_get_n_dropped (instance) result (n_dropped)
integer :: n_dropped
class(process_instance_t), intent(in) :: instance
if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
n_dropped = instance%n_dropped
else
n_dropped = 0
end if
end function process_instance_get_n_dropped
@ %def process_instance_get_sqme
@ %def process_instance_get_weight
@ %def process_instance_get_excess
@ %def process_instance_get_n_dropped
@ Return the currently selected MCI channel.
<<Instances: process instance: TBP>>=
procedure :: get_channel => process_instance_get_channel
<<Instances: sub interfaces>>=
module function process_instance_get_channel (instance) result (channel)
integer :: channel
class(process_instance_t), intent(in) :: instance
end function process_instance_get_channel
<<Instances: procedures>>=
module function process_instance_get_channel (instance) result (channel)
integer :: channel
class(process_instance_t), intent(in) :: instance
channel = instance%selected_channel
end function process_instance_get_channel
@ %def process_instance_get_channel
@
<<Instances: process instance: TBP>>=
procedure :: set_fac_scale => process_instance_set_fac_scale
<<Instances: sub interfaces>>=
module subroutine process_instance_set_fac_scale (instance, fac_scale)
class(process_instance_t), intent(inout) :: instance
real(default), intent(in) :: fac_scale
end subroutine process_instance_set_fac_scale
<<Instances: procedures>>=
module subroutine process_instance_set_fac_scale (instance, fac_scale)
class(process_instance_t), intent(inout) :: instance
real(default), intent(in) :: fac_scale
integer :: i_term
i_term = 1
call instance%term(i_term)%set_fac_scale (fac_scale)
end subroutine process_instance_set_fac_scale
@ %def process_instance_set_fac_scale
@ Return factorization scale and strong coupling. We have to select a
term instance.
<<Instances: process instance: TBP>>=
procedure :: get_fac_scale => process_instance_get_fac_scale
procedure :: get_alpha_s => process_instance_get_alpha_s
<<Instances: sub interfaces>>=
module function process_instance_get_fac_scale &
(instance, i_term) result (fac_scale)
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
real(default) :: fac_scale
end function process_instance_get_fac_scale
module function process_instance_get_alpha_s &
(instance, i_term) result (alpha_s)
real(default) :: alpha_s
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
end function process_instance_get_alpha_s
<<Instances: procedures>>=
module function process_instance_get_fac_scale &
(instance, i_term) result (fac_scale)
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
real(default) :: fac_scale
fac_scale = instance%term(i_term)%get_fac_scale ()
end function process_instance_get_fac_scale
module function process_instance_get_alpha_s &
(instance, i_term) result (alpha_s)
real(default) :: alpha_s
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
class(prc_core_t), pointer :: core => null ()
core => instance%process%get_core_term (i_term)
alpha_s = instance%term(i_term)%get_alpha_s (core)
core => null ()
end function process_instance_get_alpha_s
@ %def process_instance_get_fac_scale
@ %def process_instance_get_alpha_s
@
<<Instances: process instance: TBP>>=
procedure :: get_qcd => process_instance_get_qcd
<<Instances: sub interfaces>>=
module function process_instance_get_qcd (process_instance) result (qcd)
type(qcd_t) :: qcd
class(process_instance_t), intent(in) :: process_instance
end function process_instance_get_qcd
<<Instances: procedures>>=
module function process_instance_get_qcd (process_instance) result (qcd)
type(qcd_t) :: qcd
class(process_instance_t), intent(in) :: process_instance
qcd = process_instance%process%get_qcd ()
end function process_instance_get_qcd
@ %def process_instance_get_qcd
@ Counter.
<<Instances: process instance: TBP>>=
procedure :: reset_counter => process_instance_reset_counter
procedure :: record_call => process_instance_record_call
procedure :: get_counter => process_instance_get_counter
<<Instances: sub interfaces>>=
module subroutine process_instance_reset_counter (process_instance)
class(process_instance_t), intent(inout) :: process_instance
end subroutine process_instance_reset_counter
module subroutine process_instance_record_call (process_instance)
class(process_instance_t), intent(inout) :: process_instance
end subroutine process_instance_record_call
pure module function process_instance_get_counter &
(process_instance) result (counter)
class(process_instance_t), intent(in) :: process_instance
type(process_counter_t) :: counter
end function process_instance_get_counter
<<Instances: procedures>>=
module subroutine process_instance_reset_counter (process_instance)
class(process_instance_t), intent(inout) :: process_instance
call process_instance%mci_work(process_instance%i_mci)%reset_counter ()
end subroutine process_instance_reset_counter
module subroutine process_instance_record_call (process_instance)
class(process_instance_t), intent(inout) :: process_instance
call process_instance%mci_work(process_instance%i_mci)%record_call &
(process_instance%evaluation_status)
end subroutine process_instance_record_call
pure module function process_instance_get_counter &
(process_instance) result (counter)
class(process_instance_t), intent(in) :: process_instance
type(process_counter_t) :: counter
counter = process_instance%mci_work(process_instance%i_mci)%get_counter ()
end function process_instance_get_counter
@ %def process_instance_reset_counter
@ %def process_instance_record_call
@ %def process_instance_get_counter
@ Sum up the total number of calls for all MCI records.
<<Instances: process instance: TBP>>=
procedure :: get_actual_calls_total => process_instance_get_actual_calls_total
<<Instances: sub interfaces>>=
pure module function process_instance_get_actual_calls_total &
(process_instance) result (n)
class(process_instance_t), intent(in) :: process_instance
integer :: n
end function process_instance_get_actual_calls_total
<<Instances: procedures>>=
pure module function process_instance_get_actual_calls_total &
(process_instance) result (n)
class(process_instance_t), intent(in) :: process_instance
integer :: n
integer :: i
type(process_counter_t) :: counter
n = 0
do i = 1, size (process_instance%mci_work)
counter = process_instance%mci_work(i)%get_counter ()
n = n + counter%total
end do
end function process_instance_get_actual_calls_total
@ %def process_instance_get_actual_calls_total
@
<<Instances: process instance: TBP>>=
procedure :: reset_matrix_elements => process_instance_reset_matrix_elements
<<Instances: sub interfaces>>=
module subroutine process_instance_reset_matrix_elements (instance)
class(process_instance_t), intent(inout) :: instance
end subroutine process_instance_reset_matrix_elements
<<Instances: procedures>>=
module subroutine process_instance_reset_matrix_elements (instance)
class(process_instance_t), intent(inout) :: instance
integer :: i_term
do i_term = 1, size (instance%term)
call instance%term(i_term)%connected%trace%set_matrix_element &
(cmplx (0, 0, default))
call instance%term(i_term)%connected%matrix%set_matrix_element &
(cmplx (0, 0, default))
end do
end subroutine process_instance_reset_matrix_elements
@ %def process_instance_reset_matrix_elements
@
<<Instances: process instance: TBP>>=
procedure :: get_test_phase_space_point &
=> process_instance_get_test_phase_space_point
<<Instances: sub interfaces>>=
module subroutine process_instance_get_test_phase_space_point (instance, &
i_component, i_core, p)
type(vector4_t), dimension(:), allocatable, intent(out) :: p
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_component, i_core
end subroutine process_instance_get_test_phase_space_point
<<Instances: procedures>>=
module subroutine process_instance_get_test_phase_space_point (instance, &
i_component, i_core, p)
type(vector4_t), dimension(:), allocatable, intent(out) :: p
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_component, i_core
real(default), dimension(:), allocatable :: x
logical :: success
integer :: i_term
instance%i_mci = i_component
i_term = instance%process%get_i_term (i_core)
associate (term => instance%term(i_term), kin => instance%kin(i_term))
allocate (x (instance%mci_work(i_component)%config%n_par))
x = 0.5_default
call instance%set_mcpar (x, .true.)
call instance%select_channel (1)
call term%compute_seed_kinematics &
(kin, instance%mci_work(i_component), 1, success)
call kin%evaluate_radiation_kinematics &
(instance%mci_work(instance%i_mci)%get_x_process ())
call term%compute_hard_kinematics (kin, success = success)
allocate (p (size (term%p_hard)))
p = term%int_hard%get_momenta ()
end associate
end subroutine process_instance_get_test_phase_space_point
@ %def process_instance_get_test_phase_space_point
@
<<Instances: process instance: TBP>>=
procedure :: get_p_hard => process_instance_get_p_hard
<<Instances: sub interfaces>>=
pure module function process_instance_get_p_hard &
(process_instance, i_term) result (p_hard)
type(vector4_t), dimension(:), allocatable :: p_hard
class(process_instance_t), intent(in) :: process_instance
integer, intent(in) :: i_term
end function process_instance_get_p_hard
<<Instances: procedures>>=
pure module function process_instance_get_p_hard &
(process_instance, i_term) result (p_hard)
type(vector4_t), dimension(:), allocatable :: p_hard
class(process_instance_t), intent(in) :: process_instance
integer, intent(in) :: i_term
allocate (p_hard (size (process_instance%term(i_term)%get_p_hard ())))
p_hard = process_instance%term(i_term)%get_p_hard ()
end function process_instance_get_p_hard
@ %def process_instance_get_p_hard
@
<<Instances: process instance: TBP>>=
procedure :: get_first_active_i_term => &
process_instance_get_first_active_i_term
<<Instances: sub interfaces>>=
module function process_instance_get_first_active_i_term &
(instance) result (i_term)
integer :: i_term
class(process_instance_t), intent(in) :: instance
end function process_instance_get_first_active_i_term
<<Instances: procedures>>=
module function process_instance_get_first_active_i_term &
(instance) result (i_term)
integer :: i_term
class(process_instance_t), intent(in) :: instance
integer :: i
i_term = 0
do i = 1, size (instance%term)
if (instance%term(i)%active) then
i_term = i
exit
end if
end do
end function process_instance_get_first_active_i_term
@ %def process_instance_get_first_active_i_term
@
<<Instances: process instance: TBP>>=
procedure :: get_real_of_mci => process_instance_get_real_of_mci
<<Instances: sub interfaces>>=
module function process_instance_get_real_of_mci (instance) result (i_real)
integer :: i_real
class(process_instance_t), intent(in) :: instance
end function process_instance_get_real_of_mci
<<Instances: procedures>>=
module function process_instance_get_real_of_mci (instance) result (i_real)
integer :: i_real
class(process_instance_t), intent(in) :: instance
select type (pcm_work => instance%pcm_work)
type is (pcm_nlo_workspace_t)
i_real = pcm_work%i_mci_to_real_component (instance%i_mci)
end select
end function process_instance_get_real_of_mci
@ %def process_instance_get_real_of_mci
@
<<Instances: process instance: TBP>>=
procedure :: get_connected_states => process_instance_get_connected_states
<<Instances: sub interfaces>>=
module function process_instance_get_connected_states &
(instance, i_component) result (connected)
type(connected_state_t), dimension(:), allocatable :: connected
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_component
end function process_instance_get_connected_states
<<Instances: procedures>>=
module function process_instance_get_connected_states &
(instance, i_component) result (connected)
type(connected_state_t), dimension(:), allocatable :: connected
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_component
connected = instance%process%get_connected_states (i_component, &
instance%term(:)%connected)
end function process_instance_get_connected_states
@ %def process_instance_get_connected_states
@ Get the hadronic center-of-mass energy
<<Instances: process instance: TBP>>=
procedure :: get_sqrts => process_instance_get_sqrts
<<Instances: sub interfaces>>=
module function process_instance_get_sqrts (instance) result (sqrts)
class(process_instance_t), intent(in) :: instance
real(default) :: sqrts
end function process_instance_get_sqrts
<<Instances: procedures>>=
module function process_instance_get_sqrts (instance) result (sqrts)
class(process_instance_t), intent(in) :: instance
real(default) :: sqrts
sqrts = instance%process%get_sqrts ()
end function process_instance_get_sqrts
@ %def process_instance_get_sqrts
@ Get the polarizations
<<Instances: process instance: TBP>>=
procedure :: get_polarization => process_instance_get_polarization
<<Instances: sub interfaces>>=
module function process_instance_get_polarization (instance) result (pol)
class(process_instance_t), intent(in) :: instance
real(default), dimension(:), allocatable :: pol
end function process_instance_get_polarization
<<Instances: procedures>>=
module function process_instance_get_polarization (instance) result (pol)
class(process_instance_t), intent(in) :: instance
real(default), dimension(:), allocatable :: pol
pol = instance%process%get_polarization ()
end function process_instance_get_polarization
@ %def process_instance_get_polarization
@ Get the beam spectrum
<<Instances: process instance: TBP>>=
procedure :: get_beam_file => process_instance_get_beam_file
<<Instances: sub interfaces>>=
module function process_instance_get_beam_file (instance) result (file)
class(process_instance_t), intent(in) :: instance
type(string_t) :: file
end function process_instance_get_beam_file
<<Instances: procedures>>=
module function process_instance_get_beam_file (instance) result (file)
class(process_instance_t), intent(in) :: instance
type(string_t) :: file
file = instance%process%get_beam_file ()
end function process_instance_get_beam_file
@ %def process_instance_get_beam_file
@ Get the process name
<<Instances: process instance: TBP>>=
procedure :: get_process_name => process_instance_get_process_name
<<Instances: sub interfaces>>=
module function process_instance_get_process_name (instance) result (name)
class(process_instance_t), intent(in) :: instance
type(string_t) :: name
end function process_instance_get_process_name
<<Instances: procedures>>=
module function process_instance_get_process_name (instance) result (name)
class(process_instance_t), intent(in) :: instance
type(string_t) :: name
name = instance%process%get_id ()
end function process_instance_get_process_name
@ %def process_instance_get_process_name
@
\subsubsection{Particle sets}
Here we provide two procedures that convert the process instance
from/to a particle set. The conversion applies to the trace evaluator
which has no quantum-number information, thus it involves only the
momenta and the parent-child relations. We keep virtual particles.
If [[n_incoming]] is provided, the status code of the first
[[n_incoming]] particles will be reset to incoming. Otherwise, they
would be classified as virtual.
Nevertheless, it is possible to reconstruct the complete structure
from a particle set. The reconstruction implies a re-evaluation of
the structure function and matrix-element codes.
The [[i_term]] index is needed for both input and output, to select
among different active trace evaluators.
In both cases, the [[instance]] object must be properly initialized.
NB: The [[recover_beams]] option should be used only when the particle
set originates from an external event file, and the user has asked for
it. It should be switched off when reading from raw event file.
<<Instances: process instance: TBP>>=
procedure :: get_trace => process_instance_get_trace
procedure :: set_trace => process_instance_set_trace
<<Instances: sub interfaces>>=
module subroutine process_instance_get_trace &
(instance, pset, i_term, n_incoming)
class(process_instance_t), intent(in), target :: instance
type(particle_set_t), intent(out) :: pset
integer, intent(in) :: i_term
integer, intent(in), optional :: n_incoming
end subroutine process_instance_get_trace
module subroutine process_instance_set_trace &
(instance, pset, i_term, recover_beams, check_match, success)
class(process_instance_t), intent(inout), target :: instance
type(particle_set_t), intent(in) :: pset
integer, intent(in) :: i_term
logical, intent(in), optional :: recover_beams, check_match
logical, intent(out), optional :: success
end subroutine process_instance_set_trace
<<Instances: procedures>>=
module subroutine process_instance_get_trace &
(instance, pset, i_term, n_incoming)
class(process_instance_t), intent(in), target :: instance
type(particle_set_t), intent(out) :: pset
integer, intent(in) :: i_term
integer, intent(in), optional :: n_incoming
type(interaction_t), pointer :: int
logical :: ok
int => instance%get_trace_int_ptr (i_term)
call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
[0._default, 0._default], .false., .true., n_incoming)
end subroutine process_instance_get_trace
module subroutine process_instance_set_trace &
(instance, pset, i_term, recover_beams, check_match, success)
class(process_instance_t), intent(inout), target :: instance
type(particle_set_t), intent(in) :: pset
integer, intent(in) :: i_term
logical, intent(in), optional :: recover_beams, check_match
logical, intent(out), optional :: success
type(interaction_t), pointer :: int
integer :: n_in
int => instance%get_trace_int_ptr (i_term)
n_in = instance%process%get_n_in ()
call pset%fill_interaction (int, n_in, &
recover_beams = recover_beams, &
check_match = check_match, &
state_flv = instance%get_state_flv (i_term), &
success = success)
end subroutine process_instance_set_trace
@ %def process_instance_get_trace
@ %def process_instance_set_trace
@ This procedure allows us to override any QCD setting of the WHIZARD process
and directly set the coupling value that comes together with a particle set.
<<Instances: process instance: TBP>>=
procedure :: set_alpha_qcd_forced => process_instance_set_alpha_qcd_forced
<<Instances: sub interfaces>>=
module subroutine process_instance_set_alpha_qcd_forced &
(instance, i_term, alpha_qcd)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
real(default), intent(in) :: alpha_qcd
end subroutine process_instance_set_alpha_qcd_forced
<<Instances: procedures>>=
module subroutine process_instance_set_alpha_qcd_forced &
(instance, i_term, alpha_qcd)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
real(default), intent(in) :: alpha_qcd
call instance%term(i_term)%set_alpha_qcd_forced (alpha_qcd)
end subroutine process_instance_set_alpha_qcd_forced
@ %def process_instance_set_alpha_qcd_forced
@
<<Instances: process instance: TBP>>=
procedure :: has_nlo_component => process_instance_has_nlo_component
<<Instances: sub interfaces>>=
module function process_instance_has_nlo_component (instance) result (nlo)
class(process_instance_t), intent(in) :: instance
logical :: nlo
end function process_instance_has_nlo_component
<<Instances: procedures>>=
module function process_instance_has_nlo_component (instance) result (nlo)
class(process_instance_t), intent(in) :: instance
logical :: nlo
nlo = instance%process%is_nlo_calculation ()
end function process_instance_has_nlo_component
@ %def process_instance_has_nlo_component
@
<<Instances: process instance: TBP>>=
procedure :: keep_failed_events => process_instance_keep_failed_events
<<Instances: sub interfaces>>=
module function process_instance_keep_failed_events (instance) result (keep)
logical :: keep
class(process_instance_t), intent(in) :: instance
end function process_instance_keep_failed_events
<<Instances: procedures>>=
module function process_instance_keep_failed_events (instance) result (keep)
logical :: keep
class(process_instance_t), intent(in) :: instance
keep = instance%mci_work(instance%i_mci)%keep_failed_events
end function process_instance_keep_failed_events
@ %def process_instance_keep_failed_events
@
<<Instances: process instance: TBP>>=
procedure :: get_term_indices => process_instance_get_term_indices
<<Instances: sub interfaces>>=
module function process_instance_get_term_indices &
(instance, nlo_type) result (i_term)
integer, dimension(:), allocatable :: i_term
class(process_instance_t), intent(in) :: instance
integer :: nlo_type
end function process_instance_get_term_indices
<<Instances: procedures>>=
module function process_instance_get_term_indices &
(instance, nlo_type) result (i_term)
integer, dimension(:), allocatable :: i_term
class(process_instance_t), intent(in) :: instance
integer :: nlo_type
allocate (i_term (count (instance%term%nlo_type == nlo_type)))
i_term = pack (instance%term%get_i_term_global (), &
instance%term%nlo_type == nlo_type)
end function process_instance_get_term_indices
@ %def process_instance_get_term_indices
@
<<Instances: process instance: TBP>>=
procedure :: get_boost_to_lab => process_instance_get_boost_to_lab
<<Instances: sub interfaces>>=
module function process_instance_get_boost_to_lab &
(instance, i_term) result (lt)
type(lorentz_transformation_t) :: lt
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
end function process_instance_get_boost_to_lab
<<Instances: procedures>>=
module function process_instance_get_boost_to_lab &
(instance, i_term) result (lt)
type(lorentz_transformation_t) :: lt
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
lt = instance%kin(i_term)%get_boost_to_lab ()
end function process_instance_get_boost_to_lab
@ %def process_instance_get_boost_to_lab
@
<<Instances: process instance: TBP>>=
procedure :: get_boost_to_cms => process_instance_get_boost_to_cms
<<Instances: sub interfaces>>=
module function process_instance_get_boost_to_cms &
(instance, i_term) result (lt)
type(lorentz_transformation_t) :: lt
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
end function process_instance_get_boost_to_cms
<<Instances: procedures>>=
module function process_instance_get_boost_to_cms &
(instance, i_term) result (lt)
type(lorentz_transformation_t) :: lt
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
lt = instance%kin(i_term)%get_boost_to_cms ()
end function process_instance_get_boost_to_cms
@ %def process_instance_get_boost_to_cms
@
<<Instances: process instance: TBP>>=
procedure :: lab_is_cm => process_instance_lab_is_cm
<<Instances: sub interfaces>>=
module function process_instance_lab_is_cm &
(instance, i_term) result (lab_is_cm)
logical :: lab_is_cm
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
end function process_instance_lab_is_cm
<<Instances: procedures>>=
module function process_instance_lab_is_cm &
(instance, i_term) result (lab_is_cm)
logical :: lab_is_cm
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
lab_is_cm = instance%kin(i_term)%phs%lab_is_cm ()
end function process_instance_lab_is_cm
@ %def process_instance_lab_is_cm
@
The [[pacify]] subroutine has the purpose of setting numbers to zero
which are (by comparing with a [[tolerance]] parameter) considered
equivalent with zero. We do this in some unit tests. Here, we a
apply this to the phase space subobject of the process instance.
<<Instances: public>>=
public :: pacify
<<Instances: interfaces>>=
interface pacify
module procedure pacify_process_instance
end interface pacify
<<Instances: sub interfaces>>=
module subroutine pacify_process_instance (instance)
type(process_instance_t), intent(inout) :: instance
end subroutine pacify_process_instance
<<Instances: procedures>>=
module subroutine pacify_process_instance (instance)
type(process_instance_t), intent(inout) :: instance
integer :: i
do i = 1, size (instance%kin)
call pacify (instance%kin(i)%phs)
end do
end subroutine pacify_process_instance
@ %def pacify
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[processes_ut.f90]]>>=
<<File header>>
module processes_ut
use unit_tests
use processes_uti
<<Standard module head>>
<<Processes: public test>>
<<Processes: public test auxiliary>>
contains
<<Processes: test driver>>
end module processes_ut
@ %def processes_ut
@
<<[[processes_uti.f90]]>>=
<<File header>>
module processes_uti
<<Use kinds>>
<<Use strings>>
use format_utils, only: write_separator
use constants, only: TWOPI4
use physics_defs, only: CONV
use os_interface
use sm_qcd
use lorentz
use pdg_arrays
use model_data
use models
use var_base, only: vars_t
use variables, only: var_list_t
use model_testbed, only: prepare_model
use particle_specifiers, only: new_prt_spec
use flavors
use interactions, only: reset_interaction_counter
use particles
use rng_base
use mci_base
use mci_none, only: mci_none_t
use mci_midpoint
use sf_mappings
use sf_base
use phs_base
use phs_single
use phs_forests, only: syntax_phs_forest_init, syntax_phs_forest_final
use phs_wood, only: phs_wood_config_t
use resonances, only: resonance_history_set_t
use process_constants
use prc_core_def, only: prc_core_def_t
use prc_core
use prc_test, only: prc_test_create_library
use prc_template_me, only: template_me_def_t
use process_libraries
use prc_test_core
use pdf, only: pdf_data_t
use process_counter
use process_config, only: process_term_t
use process, only: process_t
use instances, only: process_instance_t, process_instance_hook_t
use rng_base_ut, only: rng_test_factory_t
use sf_base_ut, only: sf_test_data_t
use mci_base_ut, only: mci_test_t
use phs_base_ut, only: phs_test_config_t
<<Standard module head>>
<<Processes: public test auxiliary>>
<<Processes: test declarations>>
<<Processes: test types>>
contains
<<Processes: tests>>
<<Processes: test auxiliary>>
end module processes_uti
@ %def processes_uti
@ API: driver for the unit tests below.
<<Processes: public test>>=
public :: processes_test
<<Processes: test driver>>=
subroutine processes_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Processes: execute tests>>
end subroutine processes_test
@ %def processes_test
\subsubsection{Write an empty process object}
The most trivial test is to write an uninitialized process object.
<<Processes: execute tests>>=
call test (processes_1, "processes_1", &
"write an empty process object", &
u, results)
<<Processes: test declarations>>=
public :: processes_1
<<Processes: tests>>=
subroutine processes_1 (u)
integer, intent(in) :: u
type(process_t) :: process
write (u, "(A)") "* Test output: processes_1"
write (u, "(A)") "* Purpose: display an empty process object"
write (u, "(A)")
call process%write (.false., u)
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_1"
end subroutine processes_1
@ %def processes_1
@
\subsubsection{Initialize a process object}
Initialize a process and display it.
<<Processes: execute tests>>=
call test (processes_2, "processes_2", &
"initialize a simple process object", &
u, results)
<<Processes: test declarations>>=
public :: processes_2
<<Processes: tests>>=
subroutine processes_2 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(process_t), allocatable :: process
class(mci_t), allocatable :: mci_template
class(phs_config_t), allocatable :: phs_config_template
write (u, "(A)") "* Test output: processes_2"
write (u, "(A)") "* Purpose: initialize a simple process object"
write (u, "(A)")
write (u, "(A)") "* Build and load a test library with one process"
write (u, "(A)")
libname = "processes2"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
write (u, "(A)") "* Initialize a process object"
write (u, "(A)")
call model%init_test ()
allocate (process)
call process%init (procname, lib, os_data, model)
call process%set_run_id (var_str ("run_2"))
call process%setup_test_cores ()
allocate (phs_test_config_t :: phs_config_template)
call process%init_components (phs_config_template)
call process%setup_mci (dispatch_mci_empty)
call process%write (.false., u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_2"
end subroutine processes_2
@ %def processes_2
@ Trivial for testing: do not allocate the MCI record.
<<Processes: test auxiliary>>=
subroutine dispatch_mci_empty (mci, var_list, process_id, is_nlo)
class(mci_t), allocatable, intent(out) :: mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
logical, intent(in), optional :: is_nlo
end subroutine dispatch_mci_empty
@ %def dispatch_mci_empty
@
\subsubsection{Compute a trivial matrix element}
Initialize a process, retrieve some information and compute a matrix
element.
We use the same trivial process as for the previous test. All
momentum and state dependence is trivial, so we just test basic
functionality.
<<Processes: execute tests>>=
call test (processes_3, "processes_3", &
"retrieve a trivial matrix element", &
u, results)
<<Processes: test declarations>>=
public :: processes_3
<<Processes: tests>>=
subroutine processes_3 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(process_t), allocatable :: process
class(phs_config_t), allocatable :: phs_config_template
type(process_constants_t) :: data
type(vector4_t), dimension(:), allocatable :: p
write (u, "(A)") "* Test output: processes_3"
write (u, "(A)") "* Purpose: create a process &
&and compute a matrix element"
write (u, "(A)")
write (u, "(A)") "* Build and load a test library with one process"
write (u, "(A)")
libname = "processes3"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
call model%init_test ()
allocate (process)
call process%init (procname, lib, os_data, model)
call process%setup_test_cores ()
allocate (phs_test_config_t :: phs_config_template)
call process%init_components (phs_config_template)
call process%setup_mci (dispatch_mci_test3)
write (u, "(A)") "* Return the number of process components"
write (u, "(A)")
write (u, "(A,I0)") "n_components = ", process%get_n_components ()
write (u, "(A)")
write (u, "(A)") "* Return the number of flavor states"
write (u, "(A)")
data = process%get_constants (1)
write (u, "(A,I0)") "n_flv(1) = ", data%n_flv
write (u, "(A)")
write (u, "(A)") "* Return the first flavor state"
write (u, "(A)")
write (u, "(A,4(1x,I0))") "flv_state(1) =", data%flv_state (:,1)
write (u, "(A)")
write (u, "(A)") "* Set up kinematics &
&[arbitrary, the matrix element is constant]"
allocate (p (4))
write (u, "(A)")
write (u, "(A)") "* Retrieve the matrix element"
write (u, "(A)")
write (u, "(A,F5.3,' + ',F5.3,' I')") "me (1, p, 1, 1, 1) = ", &
process%compute_amplitude (1, 1, 1, p, 1, 1, 1)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_3"
end subroutine processes_3
@ %def processes_3
@ MCI record with some contents.
<<Processes: test auxiliary>>=
subroutine dispatch_mci_test3 (mci, var_list, process_id, is_nlo)
class(mci_t), allocatable, intent(out) :: mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
logical, intent(in), optional :: is_nlo
allocate (mci_test_t :: mci)
select type (mci)
type is (mci_test_t)
call mci%set_dimensions (2, 2)
call mci%set_divisions (100)
end select
end subroutine dispatch_mci_test3
@ %def dispatch_mci_test3
@
\subsubsection{Generate a process instance}
Initialize a process and process instance, choose a sampling point and
fill the process instance.
We use the same trivial process as for the previous test. All
momentum and state dependence is trivial, so we just test basic
functionality.
<<Processes: execute tests>>=
call test (processes_4, "processes_4", &
"create and fill a process instance (partonic event)", &
u, results)
<<Processes: test declarations>>=
public :: processes_4
<<Processes: tests>>=
subroutine processes_4 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(process_t), allocatable, target :: process
class(phs_config_t), allocatable :: phs_config_template
real(default) :: sqrts
type(process_instance_t), allocatable, target :: process_instance
type(particle_set_t) :: pset
write (u, "(A)") "* Test output: processes_4"
write (u, "(A)") "* Purpose: create a process &
&and fill a process instance"
write (u, "(A)")
write (u, "(A)") "* Build and initialize a test process"
write (u, "(A)")
libname = "processes4"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
call reset_interaction_counter ()
call model%init_test ()
allocate (process)
call process%init (procname, lib, os_data, model)
call process%setup_test_cores ()
allocate (phs_test_config_t :: phs_config_template)
call process%init_components (phs_config_template)
write (u, "(A)") "* Prepare a trivial beam setup"
write (u, "(A)")
sqrts = 1000
call process%setup_beams_sqrts (sqrts, i_core = 1)
call process%configure_phs ()
call process%setup_mci (dispatch_mci_empty)
write (u, "(A)") "* Complete process initialization"
write (u, "(A)")
call process%setup_terms ()
call process%write (.false., u)
write (u, "(A)")
write (u, "(A)") "* Create a process instance"
write (u, "(A)")
allocate (process_instance)
call process_instance%init (process)
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Inject a set of random numbers"
write (u, "(A)")
call process_instance%choose_mci (1)
call process_instance%set_mcpar ([0._default, 0._default])
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Set up hard kinematics"
write (u, "(A)")
call process_instance%select_channel (1)
call process_instance%compute_seed_kinematics ()
call process_instance%compute_hard_kinematics ()
call process_instance%compute_eff_kinematics ()
call process_instance%evaluate_expressions ()
call process_instance%compute_other_channels ()
write (u, "(A)") "* Evaluate matrix element and square"
write (u, "(A)")
call process_instance%evaluate_trace ()
call process_instance%write (u)
call process_instance%get_trace (pset, 1)
call process_instance%final ()
deallocate (process_instance)
write (u, "(A)")
write (u, "(A)") "* Particle content:"
write (u, "(A)")
call write_separator (u)
call pset%write (u)
call write_separator (u)
write (u, "(A)")
write (u, "(A)") "* Recover process instance"
write (u, "(A)")
allocate (process_instance)
call process_instance%init (process)
call process_instance%choose_mci (1)
call process_instance%set_trace (pset, 1, check_match = .false.)
call process_instance%activate ()
process_instance%evaluation_status = STAT_EFF_KINEMATICS
call process_instance%recover_hard_kinematics (i_term = 1)
call process_instance%recover_seed_kinematics (i_term = 1)
call process_instance%select_channel (1)
call process_instance%recover_mcpar (i_term = 1)
call process_instance%compute_seed_kinematics (skip_term = 1)
call process_instance%compute_hard_kinematics (skip_term = 1)
call process_instance%compute_eff_kinematics (skip_term = 1)
call process_instance%evaluate_expressions ()
call process_instance%compute_other_channels (skip_term = 1)
call process_instance%evaluate_trace ()
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call pset%final ()
call process_instance%final ()
deallocate (process_instance)
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_4"
end subroutine processes_4
@ %def processes_4
@
\subsubsection{Structure function configuration}
Configure structure functions (multi-channel) in a process object.
<<Processes: execute tests>>=
call test (processes_7, "processes_7", &
"process configuration with structure functions", &
u, results)
<<Processes: test declarations>>=
public :: processes_7
<<Processes: tests>>=
subroutine processes_7 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(process_t), allocatable, target :: process
class(phs_config_t), allocatable :: phs_config_template
real(default) :: sqrts
type(pdg_array_t) :: pdg_in
class(sf_data_t), allocatable, target :: data
type(sf_config_t), dimension(:), allocatable :: sf_config
type(sf_channel_t), dimension(2) :: sf_channel
write (u, "(A)") "* Test output: processes_7"
write (u, "(A)") "* Purpose: initialize a process with &
&structure functions"
write (u, "(A)")
write (u, "(A)") "* Build and initialize a process object"
write (u, "(A)")
libname = "processes7"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
call model%init_test ()
allocate (process)
call process%init (procname, lib, os_data, model)
call process%setup_test_cores ()
allocate (phs_test_config_t :: phs_config_template)
call process%init_components (phs_config_template)
write (u, "(A)") "* Set beam, structure functions, and mappings"
write (u, "(A)")
sqrts = 1000
call process%setup_beams_sqrts (sqrts, i_core = 1)
call process%configure_phs ()
pdg_in = 25
allocate (sf_test_data_t :: data)
select type (data)
type is (sf_test_data_t)
call data%init (process%get_model_ptr (), pdg_in)
end select
allocate (sf_config (2))
call sf_config(1)%init ([1], data)
call sf_config(2)%init ([2], data)
call process%init_sf_chain (sf_config)
deallocate (sf_config)
call process%test_allocate_sf_channels (3)
call sf_channel(1)%init (2)
call sf_channel(1)%activate_mapping ([1,2])
call process%set_sf_channel (2, sf_channel(1))
call sf_channel(2)%init (2)
call sf_channel(2)%set_s_mapping ([1,2])
call process%set_sf_channel (3, sf_channel(2))
call process%setup_mci (dispatch_mci_empty)
call process%write (.false., u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_7"
end subroutine processes_7
@ %def processes_7
@
\subsubsection{Evaluating a process with structure function}
Configure structure functions (single-channel) in a process object,
create an instance, compute kinematics and evaluate.
Note the order of operations when setting up structure functions and
phase space. The beams are first, they determine the [[sqrts]] value.
We can also set up the chain of structure functions. We then
configure the phase space. From this, we can obtain information about
special configurations (resonances, etc.), which we need for
allocating the possible structure-function channels (parameterizations
and mappings). Finally, we match phase-space channels onto
structure-function channels.
In the current example, this matching is trivial; we only have one
structure-function channel.
<<Processes: execute tests>>=
call test (processes_8, "processes_8", &
"process evaluation with structure functions", &
u, results)
<<Processes: test declarations>>=
public :: processes_8
<<Processes: tests>>=
subroutine processes_8 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(process_t), allocatable, target :: process
class(phs_config_t), allocatable :: phs_config_template
real(default) :: sqrts
type(process_instance_t), allocatable, target :: process_instance
type(pdg_array_t) :: pdg_in
class(sf_data_t), allocatable, target :: data
type(sf_config_t), dimension(:), allocatable :: sf_config
type(sf_channel_t) :: sf_channel
type(particle_set_t) :: pset
write (u, "(A)") "* Test output: processes_8"
write (u, "(A)") "* Purpose: evaluate a process with &
&structure functions"
write (u, "(A)")
write (u, "(A)") "* Build and initialize a process object"
write (u, "(A)")
libname = "processes8"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
call reset_interaction_counter ()
call model%init_test ()
allocate (process)
call process%init (procname, lib, os_data, model)
call process%setup_test_cores ()
allocate (phs_test_config_t :: phs_config_template)
call process%init_components (phs_config_template)
write (u, "(A)") "* Set beam, structure functions, and mappings"
write (u, "(A)")
sqrts = 1000
call process%setup_beams_sqrts (sqrts, i_core = 1)
pdg_in = 25
allocate (sf_test_data_t :: data)
select type (data)
type is (sf_test_data_t)
call data%init (process%get_model_ptr (), pdg_in)
end select
allocate (sf_config (2))
call sf_config(1)%init ([1], data)
call sf_config(2)%init ([2], data)
call process%init_sf_chain (sf_config)
deallocate (sf_config)
call process%configure_phs ()
call process%test_allocate_sf_channels (1)
call sf_channel%init (2)
call sf_channel%activate_mapping ([1,2])
call process%set_sf_channel (1, sf_channel)
write (u, "(A)") "* Complete process initialization"
write (u, "(A)")
call process%setup_mci (dispatch_mci_empty)
call process%setup_terms ()
call process%write (.false., u)
write (u, "(A)")
write (u, "(A)") "* Create a process instance"
write (u, "(A)")
allocate (process_instance)
call process_instance%init (process)
write (u, "(A)") "* Set up kinematics and evaluate"
write (u, "(A)")
call process_instance%choose_mci (1)
call process_instance%evaluate_sqme (1, &
[0.8_default, 0.8_default, 0.1_default, 0.2_default])
call process_instance%write (u)
call process_instance%get_trace (pset, 1)
call process_instance%final ()
deallocate (process_instance)
write (u, "(A)")
write (u, "(A)") "* Particle content:"
write (u, "(A)")
call write_separator (u)
call pacify (pset)
call pset%write (u)
call write_separator (u)
write (u, "(A)")
write (u, "(A)") "* Recover process instance"
write (u, "(A)")
call reset_interaction_counter (2)
allocate (process_instance)
call process_instance%init (process)
call process_instance%choose_mci (1)
call process_instance%set_trace (pset, 1, check_match = .false.)
call process_instance%recover &
(channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.)
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call pset%final ()
call process_instance%final ()
deallocate (process_instance)
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_8"
end subroutine processes_8
@ %def processes_8
@
\subsubsection{Multi-channel phase space and structure function}
This is an extension of the previous example. This time, we have two
distinct structure-function channels which are matched to the two
distinct phase-space channels.
<<Processes: execute tests>>=
call test (processes_9, "processes_9", &
"multichannel kinematics and structure functions", &
u, results)
<<Processes: test declarations>>=
public :: processes_9
<<Processes: tests>>=
subroutine processes_9 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(process_t), allocatable, target :: process
class(phs_config_t), allocatable :: phs_config_template
real(default) :: sqrts
type(process_instance_t), allocatable, target :: process_instance
type(pdg_array_t) :: pdg_in
class(sf_data_t), allocatable, target :: data
type(sf_config_t), dimension(:), allocatable :: sf_config
type(sf_channel_t) :: sf_channel
real(default), dimension(4) :: x_saved
type(particle_set_t) :: pset
write (u, "(A)") "* Test output: processes_9"
write (u, "(A)") "* Purpose: evaluate a process with &
&structure functions"
write (u, "(A)") "* in a multi-channel configuration"
write (u, "(A)")
write (u, "(A)") "* Build and initialize a process object"
write (u, "(A)")
libname = "processes9"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
call reset_interaction_counter ()
call model%init_test ()
allocate (process)
call process%init (procname, lib, os_data, model)
call process%setup_test_cores ()
allocate (phs_test_config_t :: phs_config_template)
call process%init_components (phs_config_template)
write (u, "(A)") "* Set beam, structure functions, and mappings"
write (u, "(A)")
sqrts = 1000
call process%setup_beams_sqrts (sqrts, i_core = 1)
pdg_in = 25
allocate (sf_test_data_t :: data)
select type (data)
type is (sf_test_data_t)
call data%init (process%get_model_ptr (), pdg_in)
end select
allocate (sf_config (2))
call sf_config(1)%init ([1], data)
call sf_config(2)%init ([2], data)
call process%init_sf_chain (sf_config)
deallocate (sf_config)
call process%configure_phs ()
call process%test_allocate_sf_channels (2)
call sf_channel%init (2)
call process%set_sf_channel (1, sf_channel)
call sf_channel%init (2)
call sf_channel%activate_mapping ([1,2])
call process%set_sf_channel (2, sf_channel)
call process%test_set_component_sf_channel ([1, 2])
write (u, "(A)") "* Complete process initialization"
write (u, "(A)")
call process%setup_mci (dispatch_mci_empty)
call process%setup_terms ()
call process%write (.false., u)
write (u, "(A)")
write (u, "(A)") "* Create a process instance"
write (u, "(A)")
allocate (process_instance)
call process_instance%init (process)
write (u, "(A)") "* Set up kinematics in channel 1 and evaluate"
write (u, "(A)")
call process_instance%choose_mci (1)
call process_instance%evaluate_sqme (1, &
[0.8_default, 0.8_default, 0.1_default, 0.2_default])
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Extract MC input parameters"
write (u, "(A)")
write (u, "(A)") "Channel 1:"
call process_instance%get_mcpar (1, x_saved)
write (u, "(2x,9(1x,F7.5))") x_saved
write (u, "(A)") "Channel 2:"
call process_instance%get_mcpar (2, x_saved)
write (u, "(2x,9(1x,F7.5))") x_saved
write (u, "(A)")
write (u, "(A)") "* Set up kinematics in channel 2 and evaluate"
write (u, "(A)")
call process_instance%evaluate_sqme (2, x_saved)
call process_instance%write (u)
call process_instance%get_trace (pset, 1)
call process_instance%final ()
deallocate (process_instance)
write (u, "(A)")
write (u, "(A)") "* Recover process instance for channel 2"
write (u, "(A)")
call reset_interaction_counter (2)
allocate (process_instance)
call process_instance%init (process)
call process_instance%choose_mci (1)
call process_instance%set_trace (pset, 1, check_match = .false.)
call process_instance%recover &
(channel = 2, i_term = 1, update_sqme = .true., recover_phs = .true.)
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call pset%final ()
call process_instance%final ()
deallocate (process_instance)
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_9"
end subroutine processes_9
@ %def processes_9
@
\subsubsection{Event generation}
Activate the MC integrator for the process object and use it to
generate a single event. Note that the test integrator does not
require integration in preparation for generating events.
<<Processes: execute tests>>=
call test (processes_10, "processes_10", &
"event generation", &
u, results)
<<Processes: test declarations>>=
public :: processes_10
<<Processes: tests>>=
subroutine processes_10 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(process_t), allocatable, target :: process
class(mci_t), pointer :: mci
class(phs_config_t), allocatable :: phs_config_template
real(default) :: sqrts
type(process_instance_t), allocatable, target :: process_instance
write (u, "(A)") "* Test output: processes_10"
write (u, "(A)") "* Purpose: generate events for a process without &
&structure functions"
write (u, "(A)") "* in a multi-channel configuration"
write (u, "(A)")
write (u, "(A)") "* Build and initialize a process object"
write (u, "(A)")
libname = "processes10"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
call reset_interaction_counter ()
call model%init_test ()
allocate (process)
call process%init (procname, lib, os_data, model)
call process%setup_test_cores ()
allocate (phs_test_config_t :: phs_config_template)
call process%init_components (phs_config_template)
write (u, "(A)") "* Prepare a trivial beam setup"
write (u, "(A)")
sqrts = 1000
call process%setup_beams_sqrts (sqrts, i_core = 1)
call process%configure_phs ()
call process%setup_mci (dispatch_mci_test10)
write (u, "(A)") "* Complete process initialization"
write (u, "(A)")
call process%setup_terms ()
call process%write (.false., u)
write (u, "(A)")
write (u, "(A)") "* Create a process instance"
write (u, "(A)")
allocate (process_instance)
call process_instance%init (process)
write (u, "(A)") "* Generate weighted event"
write (u, "(A)")
call process%test_get_mci_ptr (mci)
select type (mci)
type is (mci_test_t)
! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7
call mci%rng%init (3)
! Include the constant PHS factor in the stored maximum of the integrand
call mci%set_max_factor (conv * twopi4 &
/ (2 * sqrt (lambda (sqrts **2, 125._default**2, 125._default**2))))
end select
call process_instance%generate_weighted_event (1)
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Generate unweighted event"
write (u, "(A)")
call process_instance%generate_unweighted_event (1)
call process%test_get_mci_ptr (mci)
select type (mci)
type is (mci_test_t)
write (u, "(A,I0)") " Success in try ", mci%tries
write (u, "(A)")
end select
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process_instance%final ()
deallocate (process_instance)
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_10"
end subroutine processes_10
@ %def processes_10
@ MCI record with some contents.
<<Processes: test auxiliary>>=
subroutine dispatch_mci_test10 (mci, var_list, process_id, is_nlo)
class(mci_t), allocatable, intent(out) :: mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
logical, intent(in), optional :: is_nlo
allocate (mci_test_t :: mci)
select type (mci)
type is (mci_test_t); call mci%set_divisions (100)
end select
end subroutine dispatch_mci_test10
@ %def dispatch_mci_test10
@
\subsubsection{Integration}
Activate the MC integrator for the process object and use it to
integrate over phase space.
<<Processes: execute tests>>=
call test (processes_11, "processes_11", &
"integration", &
u, results)
<<Processes: test declarations>>=
public :: processes_11
<<Processes: tests>>=
subroutine processes_11 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(process_t), allocatable, target :: process
class(mci_t), allocatable :: mci_template
class(phs_config_t), allocatable :: phs_config_template
real(default) :: sqrts
type(process_instance_t), allocatable, target :: process_instance
write (u, "(A)") "* Test output: processes_11"
write (u, "(A)") "* Purpose: integrate a process without &
&structure functions"
write (u, "(A)") "* in a multi-channel configuration"
write (u, "(A)")
write (u, "(A)") "* Build and initialize a process object"
write (u, "(A)")
libname = "processes11"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
call reset_interaction_counter ()
call model%init_test ()
allocate (process)
call process%init (procname, lib, os_data, model)
call process%setup_test_cores ()
allocate (phs_test_config_t :: phs_config_template)
call process%init_components (phs_config_template)
write (u, "(A)") "* Prepare a trivial beam setup"
write (u, "(A)")
sqrts = 1000
call process%setup_beams_sqrts (sqrts, i_core = 1)
call process%configure_phs ()
call process%setup_mci (dispatch_mci_test10)
write (u, "(A)") "* Complete process initialization"
write (u, "(A)")
call process%setup_terms ()
call process%write (.false., u)
write (u, "(A)")
write (u, "(A)") "* Create a process instance"
write (u, "(A)")
allocate (process_instance)
call process_instance%init (process)
write (u, "(A)") "* Integrate with default test parameters"
write (u, "(A)")
call process_instance%integrate (1, n_it=1, n_calls=10000)
call process%final_integration (1)
call process%write (.false., u)
write (u, "(A)")
write (u, "(A,ES13.7)") " Integral divided by phs factor = ", &
process%get_integral (1) &
/ process_instance%kin(1)%phs_factor
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process_instance%final ()
deallocate (process_instance)
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_11"
end subroutine processes_11
@ %def processes_11
@
\subsubsection{Complete events}
For the purpose of simplifying further tests, we implement a
convenience routine that initializes a process and prepares a single
event. This is a wrapup of the test [[processes_10]].
The procedure is re-exported by the [[processes_ut]] module.
<<Processes: public test auxiliary>>=
public :: prepare_test_process
<<Processes: test auxiliary>>=
subroutine prepare_test_process &
(process, process_instance, model, var_list, run_id)
type(process_t), intent(out), target :: process
type(process_instance_t), intent(out), target :: process_instance
class(model_data_t), intent(in), target :: model
type(var_list_t), intent(inout), optional :: var_list
type(string_t), intent(in), optional :: run_id
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), allocatable, target :: process_model
class(mci_t), pointer :: mci
class(phs_config_t), allocatable :: phs_config_template
real(default) :: sqrts
libname = "processes_test"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
call reset_interaction_counter ()
allocate (process_model)
call process_model%init (model%get_name (), &
model%get_n_real (), &
model%get_n_complex (), &
model%get_n_field (), &
model%get_n_vtx ())
call process_model%copy_from (model)
call process%init (procname, lib, os_data, process_model, var_list)
if (present (run_id)) call process%set_run_id (run_id)
call process%setup_test_cores ()
allocate (phs_test_config_t :: phs_config_template)
call process%init_components (phs_config_template)
sqrts = 1000
call process%setup_beams_sqrts (sqrts, i_core = 1)
call process%configure_phs ()
call process%setup_mci (dispatch_mci_test10)
call process%setup_terms ()
call process_instance%init (process)
call process%test_get_mci_ptr (mci)
select type (mci)
type is (mci_test_t)
! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7
call mci%rng%init (3)
! Include the constant PHS factor in the stored maximum of the integrand
call mci%set_max_factor (conv * twopi4 &
/ (2 * sqrt (lambda (sqrts **2, 125._default**2, 125._default**2))))
end select
call process%reset_library_ptr () ! avoid dangling pointer
call process_model%final ()
end subroutine prepare_test_process
@ %def prepare_test_process
@ Here we do the cleanup of the process and process instance emitted
by the previous routine.
<<Processes: public test auxiliary>>=
public :: cleanup_test_process
<<Processes: test auxiliary>>=
subroutine cleanup_test_process (process, process_instance)
type(process_t), intent(inout) :: process
type(process_instance_t), intent(inout) :: process_instance
call process_instance%final ()
call process%final ()
end subroutine cleanup_test_process
@ %def cleanup_test_process
@
This is the actual test. Prepare the test process and event, fill
all evaluators, and display the results. Use a particle set as
temporary storage, read kinematics and recalculate the event.
<<Processes: execute tests>>=
call test (processes_12, "processes_12", &
"event post-processing", &
u, results)
<<Processes: test declarations>>=
public :: processes_12
<<Processes: tests>>=
subroutine processes_12 (u)
integer, intent(in) :: u
type(process_t), allocatable, target :: process
type(process_instance_t), allocatable, target :: process_instance
type(particle_set_t) :: pset
type(model_data_t), target :: model
write (u, "(A)") "* Test output: processes_12"
write (u, "(A)") "* Purpose: generate a complete partonic event"
write (u, "(A)")
call model%init_test ()
write (u, "(A)") "* Build and initialize process and process instance &
&and generate event"
write (u, "(A)")
allocate (process)
allocate (process_instance)
call prepare_test_process (process, process_instance, model, &
run_id = var_str ("run_12"))
call process_instance%setup_event_data (i_core = 1)
call process%prepare_simulation (1)
call process_instance%init_simulation (1)
call process_instance%generate_weighted_event (1)
call process_instance%evaluate_event_data ()
call process_instance%write (u)
call process_instance%get_trace (pset, 1)
call process_instance%final_simulation (1)
call process_instance%final ()
deallocate (process_instance)
write (u, "(A)")
write (u, "(A)") "* Recover kinematics and recalculate"
write (u, "(A)")
call reset_interaction_counter (2)
allocate (process_instance)
call process_instance%init (process)
call process_instance%setup_event_data ()
call process_instance%choose_mci (1)
call process_instance%set_trace (pset, 1, check_match = .false.)
call process_instance%recover &
(channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.)
call process_instance%recover_event ()
call process_instance%evaluate_event_data ()
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call cleanup_test_process (process, process_instance)
deallocate (process_instance)
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_12"
end subroutine processes_12
@ %def processes_12
@
\subsubsection{Colored interaction}
This test specifically checks the transformation of process data
(flavor, helicity, and color) into an interaction in a process term.
We use the [[test_t]] process core (which has no nontrivial
particles), but call only the [[is_allowed]] method, which always
returns true.
<<Processes: execute tests>>=
call test (processes_13, "processes_13", &
"colored interaction", &
u, results)
<<Processes: test declarations>>=
public :: processes_13
<<Processes: tests>>=
subroutine processes_13 (u)
integer, intent(in) :: u
type(os_data_t) :: os_data
type(model_data_t), target :: model
type(process_term_t) :: term
class(prc_core_t), allocatable :: core
write (u, "(A)") "* Test output: processes_13"
write (u, "(A)") "* Purpose: initialized a colored interaction"
write (u, "(A)")
write (u, "(A)") "* Set up a process constants block"
write (u, "(A)")
call os_data%init ()
call model%init_sm_test ()
allocate (test_t :: core)
associate (data => term%data)
data%n_in = 2
data%n_out = 3
data%n_flv = 2
data%n_hel = 2
data%n_col = 2
data%n_cin = 2
allocate (data%flv_state (5, 2))
data%flv_state (:,1) = [ 1, 21, 1, 21, 21]
data%flv_state (:,2) = [ 2, 21, 2, 21, 21]
allocate (data%hel_state (5, 2))
data%hel_state (:,1) = [1, 1, 1, 1, 0]
data%hel_state (:,2) = [1,-1, 1,-1, 0]
allocate (data%col_state (2, 5, 2))
data%col_state (:,:,1) = &
reshape ([[1, 0], [2,-1], [3, 0], [2,-3], [0,0]], [2,5])
data%col_state (:,:,2) = &
reshape ([[1, 0], [2,-3], [3, 0], [2,-1], [0,0]], [2,5])
allocate (data%ghost_flag (5, 2))
data%ghost_flag(1:4,:) = .false.
data%ghost_flag(5,:) = .true.
end associate
write (u, "(A)") "* Set up the interaction"
write (u, "(A)")
call reset_interaction_counter ()
call term%setup_interaction (core, model)
call term%int%basic_write (u)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_13"
end subroutine processes_13
@ %def processes_13
@
\subsubsection{MD5 sums}
Configure a process with structure functions (multi-channel) and
compute MD5 sums
<<Processes: execute tests>>=
call test (processes_14, "processes_14", &
"process configuration and MD5 sum", &
u, results)
<<Processes: test declarations>>=
public :: processes_14
<<Processes: tests>>=
subroutine processes_14 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(process_t), allocatable, target :: process
class(phs_config_t), allocatable :: phs_config_template
real(default) :: sqrts
type(pdg_array_t) :: pdg_in
class(sf_data_t), allocatable, target :: data
type(sf_config_t), dimension(:), allocatable :: sf_config
type(sf_channel_t), dimension(3) :: sf_channel
write (u, "(A)") "* Test output: processes_14"
write (u, "(A)") "* Purpose: initialize a process with &
&structure functions"
write (u, "(A)") "* and compute MD5 sum"
write (u, "(A)")
write (u, "(A)") "* Build and initialize a process object"
write (u, "(A)")
libname = "processes7"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
call lib%compute_md5sum ()
call model%init_test ()
allocate (process)
call process%init (procname, lib, os_data, model)
call process%setup_test_cores ()
allocate (phs_test_config_t :: phs_config_template)
call process%init_components (phs_config_template)
write (u, "(A)") "* Set beam, structure functions, and mappings"
write (u, "(A)")
sqrts = 1000
call process%setup_beams_sqrts (sqrts, i_core = 1)
call process%configure_phs ()
pdg_in = 25
allocate (sf_test_data_t :: data)
select type (data)
type is (sf_test_data_t)
call data%init (process%get_model_ptr (), pdg_in)
end select
call process%test_allocate_sf_channels (3)
allocate (sf_config (2))
call sf_config(1)%init ([1], data)
call sf_config(2)%init ([2], data)
call process%init_sf_chain (sf_config)
deallocate (sf_config)
call sf_channel(1)%init (2)
call process%set_sf_channel (1, sf_channel(1))
call sf_channel(2)%init (2)
call sf_channel(2)%activate_mapping ([1,2])
call process%set_sf_channel (2, sf_channel(2))
call sf_channel(3)%init (2)
call sf_channel(3)%set_s_mapping ([1,2])
call process%set_sf_channel (3, sf_channel(3))
call process%setup_mci (dispatch_mci_empty)
call process%compute_md5sum ()
call process%write (.false., u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_14"
end subroutine processes_14
@ %def processes_14
@
\subsubsection{Decay Process Evaluation}
Initialize an evaluate a decay process.
<<Processes: execute tests>>=
call test (processes_15, "processes_15", &
"decay process", &
u, results)
<<Processes: test declarations>>=
public :: processes_15
<<Processes: tests>>=
subroutine processes_15 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(process_t), allocatable, target :: process
class(phs_config_t), allocatable :: phs_config_template
type(process_instance_t), allocatable, target :: process_instance
type(particle_set_t) :: pset
write (u, "(A)") "* Test output: processes_15"
write (u, "(A)") "* Purpose: initialize a decay process object"
write (u, "(A)")
write (u, "(A)") "* Build and load a test library with one process"
write (u, "(A)")
libname = "processes15"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib, scattering = .false., &
decay = .true.)
call model%init_test ()
call model%set_par (var_str ("ff"), 0.4_default)
call model%set_par (var_str ("mf"), &
model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
write (u, "(A)") "* Initialize a process object"
write (u, "(A)")
allocate (process)
call process%init (procname, lib, os_data, model)
call process%setup_test_cores ()
allocate (phs_single_config_t :: phs_config_template)
call process%init_components (phs_config_template)
write (u, "(A)") "* Prepare a trivial beam setup"
write (u, "(A)")
call process%setup_beams_decay (i_core = 1)
call process%configure_phs ()
call process%setup_mci (dispatch_mci_empty)
write (u, "(A)") "* Complete process initialization"
write (u, "(A)")
call process%setup_terms ()
call process%write (.false., u)
write (u, "(A)")
write (u, "(A)") "* Create a process instance"
write (u, "(A)")
call reset_interaction_counter (3)
allocate (process_instance)
call process_instance%init (process)
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Inject a set of random numbers"
write (u, "(A)")
call process_instance%choose_mci (1)
call process_instance%set_mcpar ([0._default, 0._default])
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Set up hard kinematics"
write (u, "(A)")
call process_instance%select_channel (1)
call process_instance%compute_seed_kinematics ()
call process_instance%compute_hard_kinematics ()
write (u, "(A)") "* Evaluate matrix element and square"
write (u, "(A)")
call process_instance%compute_eff_kinematics ()
call process_instance%evaluate_expressions ()
call process_instance%compute_other_channels ()
call process_instance%evaluate_trace ()
call process_instance%write (u)
call process_instance%get_trace (pset, 1)
call process_instance%final ()
deallocate (process_instance)
write (u, "(A)")
write (u, "(A)") "* Particle content:"
write (u, "(A)")
call write_separator (u)
call pset%write (u)
call write_separator (u)
write (u, "(A)")
write (u, "(A)") "* Recover process instance"
write (u, "(A)")
call reset_interaction_counter (3)
allocate (process_instance)
call process_instance%init (process)
call process_instance%choose_mci (1)
call process_instance%set_trace (pset, 1, check_match = .false.)
call process_instance%recover (1, 1, .true., .true.)
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call pset%final ()
call process_instance%final ()
deallocate (process_instance)
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_15"
end subroutine processes_15
@ %def processes_15
@
\subsubsection{Integration: decay}
Activate the MC integrator for the decay object and use it to
integrate over phase space.
<<Processes: execute tests>>=
call test (processes_16, "processes_16", &
"decay integration", &
u, results)
<<Processes: test declarations>>=
public :: processes_16
<<Processes: tests>>=
subroutine processes_16 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(process_t), allocatable, target :: process
class(phs_config_t), allocatable :: phs_config_template
type(process_instance_t), allocatable, target :: process_instance
write (u, "(A)") "* Test output: processes_16"
write (u, "(A)") "* Purpose: integrate a process without &
&structure functions"
write (u, "(A)") "* in a multi-channel configuration"
write (u, "(A)")
write (u, "(A)") "* Build and initialize a process object"
write (u, "(A)")
libname = "processes16"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib, scattering = .false., &
decay = .true.)
call reset_interaction_counter ()
call model%init_test ()
call model%set_par (var_str ("ff"), 0.4_default)
call model%set_par (var_str ("mf"), &
model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
allocate (process)
call process%init (procname, lib, os_data, model)
call process%setup_test_cores ()
allocate (phs_single_config_t :: phs_config_template)
call process%init_components (phs_config_template)
write (u, "(A)") "* Prepare a trivial beam setup"
write (u, "(A)")
call process%setup_beams_decay (i_core = 1)
call process%configure_phs ()
call process%setup_mci (dispatch_mci_test_midpoint)
write (u, "(A)") "* Complete process initialization"
write (u, "(A)")
call process%setup_terms ()
call process%write (.false., u)
write (u, "(A)")
write (u, "(A)") "* Create a process instance"
write (u, "(A)")
allocate (process_instance)
call process_instance%init (process)
write (u, "(A)") "* Integrate with default test parameters"
write (u, "(A)")
call process_instance%integrate (1, n_it=1, n_calls=10000)
call process%final_integration (1)
call process%write (.false., u)
write (u, "(A)")
write (u, "(A,ES13.7)") " Integral divided by phs factor = ", &
process%get_integral (1) &
/ process_instance%kin(1)%phs_factor
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process_instance%final ()
deallocate (process_instance)
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_16"
end subroutine processes_16
@ %def processes_16
@ MCI record prepared for midpoint integrator.
<<Processes: test auxiliary>>=
subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo)
class(mci_t), allocatable, intent(out) :: mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
logical, intent(in), optional :: is_nlo
allocate (mci_midpoint_t :: mci)
end subroutine dispatch_mci_test_midpoint
@ %def dispatch_mci_test_midpoint
@
\subsubsection{Decay Process Evaluation}
Initialize an evaluate a decay process for a moving particle.
<<Processes: execute tests>>=
call test (processes_17, "processes_17", &
"decay of moving particle", &
u, results)
<<Processes: test declarations>>=
public :: processes_17
<<Processes: tests>>=
subroutine processes_17 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(process_t), allocatable, target :: process
class(phs_config_t), allocatable :: phs_config_template
type(process_instance_t), allocatable, target :: process_instance
type(particle_set_t) :: pset
type(flavor_t) :: flv_beam
real(default) :: m, p, E
write (u, "(A)") "* Test output: processes_17"
write (u, "(A)") "* Purpose: initialize a decay process object"
write (u, "(A)")
write (u, "(A)") "* Build and load a test library with one process"
write (u, "(A)")
libname = "processes17"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib, scattering = .false., &
decay = .true.)
write (u, "(A)") "* Initialize a process object"
write (u, "(A)")
call model%init_test ()
call model%set_par (var_str ("ff"), 0.4_default)
call model%set_par (var_str ("mf"), &
model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
allocate (process)
call process%init (procname, lib, os_data, model)
call process%setup_test_cores ()
allocate (phs_single_config_t :: phs_config_template)
call process%init_components (phs_config_template)
write (u, "(A)") "* Prepare a trivial beam setup"
write (u, "(A)")
call process%setup_beams_decay (rest_frame = .false., i_core = 1)
call process%configure_phs ()
call process%setup_mci (dispatch_mci_empty)
write (u, "(A)") "* Complete process initialization"
write (u, "(A)")
call process%setup_terms ()
call process%write (.false., u)
write (u, "(A)")
write (u, "(A)") "* Create a process instance"
write (u, "(A)")
call reset_interaction_counter (3)
allocate (process_instance)
call process_instance%init (process)
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Set parent momentum and random numbers"
write (u, "(A)")
call process_instance%choose_mci (1)
call process_instance%set_mcpar ([0._default, 0._default])
call flv_beam%init (25, process%get_model_ptr ())
m = flv_beam%get_mass ()
p = 3 * m / 4
E = sqrt (m**2 + p**2)
call process_instance%set_beam_momenta ([vector4_moving (E, p, 3)])
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Set up hard kinematics"
write (u, "(A)")
call process_instance%select_channel (1)
call process_instance%compute_seed_kinematics ()
call process_instance%compute_hard_kinematics ()
write (u, "(A)") "* Evaluate matrix element and square"
write (u, "(A)")
call process_instance%compute_eff_kinematics ()
call process_instance%evaluate_expressions ()
call process_instance%compute_other_channels ()
call process_instance%evaluate_trace ()
call process_instance%write (u)
call process_instance%get_trace (pset, 1)
call process_instance%final ()
deallocate (process_instance)
write (u, "(A)")
write (u, "(A)") "* Particle content:"
write (u, "(A)")
call write_separator (u)
call pset%write (u)
call write_separator (u)
write (u, "(A)")
write (u, "(A)") "* Recover process instance"
write (u, "(A)")
call reset_interaction_counter (3)
allocate (process_instance)
call process_instance%init (process)
call process_instance%choose_mci (1)
call process_instance%set_trace (pset, 1, check_match = .false.)
call process_instance%recover (1, 1, .true., .true.)
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call pset%final ()
call process_instance%final ()
deallocate (process_instance)
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_17"
end subroutine processes_17
@ %def processes_17
@
\subsubsection{Resonances in Phase Space}
This test demonstrates the extraction of the resonance-history set from the
generated phase space. We need a nontrivial process, but no matrix element.
This is provided by the [[prc_template]] method, using the [[SM]] model. We
also need the [[phs_wood]] method, otherwise we would not have resonances in
the phase space configuration.
<<Processes: execute tests>>=
call test (processes_18, "processes_18", &
"extract resonance history set", &
u, results)
<<Processes: test declarations>>=
public :: processes_18
<<Processes: tests>>=
subroutine processes_18 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(string_t) :: model_name
type(os_data_t) :: os_data
class(model_data_t), pointer :: model
class(vars_t), pointer :: vars
type(process_t), pointer :: process
type(resonance_history_set_t) :: res_set
integer :: i
write (u, "(A)") "* Test output: processes_18"
write (u, "(A)") "* Purpose: extra resonance histories"
write (u, "(A)")
write (u, "(A)") "* Build and load a test library with one process"
write (u, "(A)")
libname = "processes_18_lib"
procname = "processes_18_p"
call os_data%init ()
call syntax_phs_forest_init ()
model_name = "SM"
model => null ()
call prepare_model (model, model_name, vars)
write (u, "(A)") "* Initialize a process library with one process"
write (u, "(A)")
select type (model)
class is (model_t)
call prepare_resonance_test_library (lib, libname, procname, model, os_data, u)
end select
write (u, "(A)")
write (u, "(A)") "* Initialize a process object with phase space"
allocate (process)
select type (model)
class is (model_t)
call prepare_resonance_test_process (process, lib, procname, model, os_data)
end select
write (u, "(A)")
write (u, "(A)") "* Extract resonance history set"
write (u, "(A)")
call process%extract_resonance_history_set (res_set)
call res_set%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process%final ()
deallocate (process)
call model%final ()
deallocate (model)
call syntax_phs_forest_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_18"
end subroutine processes_18
@ %def processes_18
@ Auxiliary subroutine that constructs the process library for the above test.
<<Processes: test auxiliary>>=
subroutine prepare_resonance_test_library &
(lib, libname, procname, model, os_data, u)
type(process_library_t), target, intent(out) :: lib
type(string_t), intent(in) :: libname
type(string_t), intent(in) :: procname
type(model_t), intent(in), target :: model
type(os_data_t), intent(in) :: os_data
integer, intent(in) :: u
type(string_t), dimension(:), allocatable :: prt_in, prt_out
class(prc_core_def_t), allocatable :: def
type(process_def_entry_t), pointer :: entry
call lib%init (libname)
allocate (prt_in (2), prt_out (3))
prt_in = [var_str ("e+"), var_str ("e-")]
prt_out = [var_str ("d"), var_str ("ubar"), var_str ("W+")]
allocate (template_me_def_t :: def)
select type (def)
type is (template_me_def_t)
call def%init (model, prt_in, prt_out, unity = .false.)
end select
allocate (entry)
call entry%init (procname, &
model_name = model%get_name (), &
n_in = 2, n_components = 1)
call entry%import_component (1, n_out = size (prt_out), &
prt_in = new_prt_spec (prt_in), &
prt_out = new_prt_spec (prt_out), &
method = var_str ("template"), &
variant = def)
call entry%write (u)
call lib%append (entry)
call lib%configure (os_data)
call lib%write_makefile (os_data, force = .true., verbose = .false.)
call lib%clean (os_data, distclean = .false.)
call lib%write_driver (force = .true.)
call lib%load (os_data)
end subroutine prepare_resonance_test_library
@ %def prepare_resonance_test_library
@ We want a test process which has been initialized up to the point where we
can evaluate the matrix element. This is in fact rather complicated. We copy
the steps from [[integration_setup_process]] in the [[integrate]] module,
which is not available at this point.
<<Processes: test auxiliary>>=
subroutine prepare_resonance_test_process &
(process, lib, procname, model, os_data)
class(process_t), intent(out), target :: process
type(process_library_t), intent(in), target :: lib
type(string_t), intent(in) :: procname
type(model_t), intent(in), target :: model
type(os_data_t), intent(in) :: os_data
class(phs_config_t), allocatable :: phs_config_template
real(default) :: sqrts
call process%init (procname, lib, os_data, model)
allocate (phs_wood_config_t :: phs_config_template)
call process%init_components (phs_config_template)
call process%setup_test_cores (type_string = var_str ("template"))
sqrts = 1000
call process%setup_beams_sqrts (sqrts, i_core = 1)
call process%configure_phs ()
call process%setup_mci (dispatch_mci_none)
call process%setup_terms ()
end subroutine prepare_resonance_test_process
@ %def prepare_resonance_test_process
@ MCI record prepared for the none (dummy) integrator.
<<Processes: test auxiliary>>=
subroutine dispatch_mci_none (mci, var_list, process_id, is_nlo)
class(mci_t), allocatable, intent(out) :: mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
logical, intent(in), optional :: is_nlo
allocate (mci_none_t :: mci)
end subroutine dispatch_mci_none
@ %def dispatch_mci_none
@
\subsubsection{Add after evaluate hook(s)}
Initialize a process and process instance, add a trivial process hook,
choose a sampling point and fill the process instance.
We use the same trivial process as for the previous test. All
momentum and state dependence is trivial, so we just test basic
functionality.
<<Processes: test types>>=
type, extends(process_instance_hook_t) :: process_instance_hook_test_t
integer :: unit
character(len=15) :: name
contains
procedure :: init => process_instance_hook_test_init
procedure :: final => process_instance_hook_test_final
procedure :: evaluate => process_instance_hook_test_evaluate
end type process_instance_hook_test_t
@
<<Processes: test auxiliary>>=
subroutine process_instance_hook_test_init (hook, var_list, instance, pdf_data)
class(process_instance_hook_test_t), intent(inout), target :: hook
type(var_list_t), intent(in) :: var_list
class(process_instance_t), intent(in), target :: instance
type(pdf_data_t), intent(in), optional :: pdf_data
end subroutine process_instance_hook_test_init
subroutine process_instance_hook_test_final (hook)
class(process_instance_hook_test_t), intent(inout) :: hook
end subroutine process_instance_hook_test_final
subroutine process_instance_hook_test_evaluate (hook, instance)
class(process_instance_hook_test_t), intent(inout) :: hook
class(process_instance_t), intent(in), target :: instance
write (hook%unit, "(A)") "Execute hook:"
write (hook%unit, "(2X,A,1X,A,I0,A)") hook%name, "(", len (trim (hook%name)), ")"
end subroutine process_instance_hook_test_evaluate
@
<<Processes: execute tests>>=
call test (processes_19, "processes_19", &
"add trivial hooks to a process instance ", &
u, results)
<<Processes: test declarations>>=
public :: processes_19
<<Processes: tests>>=
subroutine processes_19 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
class(model_data_t), pointer :: model
type(process_t), allocatable, target :: process
class(phs_config_t), allocatable :: phs_config_template
real(default) :: sqrts
type(process_instance_t) :: process_instance
class(process_instance_hook_t), allocatable, target :: process_instance_hook, process_instance_hook2
type(particle_set_t) :: pset
write (u, "(A)") "* Test output: processes_19"
write (u, "(A)") "* Purpose: allocate process instance &
&and add an after evaluate hook"
write (u, "(A)")
write (u, "(A)")
write (u, "(A)") "* Allocate a process instance"
write (u, "(A)")
call process_instance%write (u)
write (u, "(A)")
write (u, "(A)") "* Allocate hook and add to process instance"
write (u, "(A)")
allocate (process_instance_hook_test_t :: process_instance_hook)
call process_instance%append_after_hook (process_instance_hook)
allocate (process_instance_hook_test_t :: process_instance_hook2)
call process_instance%append_after_hook (process_instance_hook2)
select type (process_instance_hook)
type is (process_instance_hook_test_t)
process_instance_hook%unit = u
process_instance_hook%name = "Hook 1"
end select
select type (process_instance_hook2)
type is (process_instance_hook_test_t)
process_instance_hook2%unit = u
process_instance_hook2%name = "Hook 2"
end select
write (u, "(A)") "* Evaluate matrix element and square"
write (u, "(A)")
call process_instance%evaluate_after_hook ()
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process_instance_hook%final ()
deallocate (process_instance_hook)
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_19"
end subroutine processes_19
@ %def processes_19
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Process Stacks}
For storing and handling multiple processes, we define process stacks.
These are ordinary stacks where new process entries are pushed onto
the top. We allow for multiple entries with identical process ID, but
distinct run ID.
The implementation is essentially identical to the [[prclib_stacks]] module
above. Unfortunately, Fortran supports no generic programming, so we do not
make use of this fact.
When searching for a specific process ID, we will get (a pointer to)
the topmost process entry with that ID on the stack, which was entered
last. Usually, this is the best version of the process (in terms of
integral, etc.) Thus the stack terminology makes sense.
<<[[process_stacks.f90]]>>=
<<File header>>
module process_stacks
<<Use kinds>>
<<Use strings>>
use variables
use process
<<Standard module head>>
<<Process stacks: public>>
<<Process stacks: types>>
interface
<<Process stacks: sub interfaces>>
end interface
end module process_stacks
@ %def process_stacks
@
<<[[process_stacks_sub.f90]]>>=
<<File header>>
submodule (process_stacks) process_stacks_s
use io_units
use format_utils, only: write_separator
use diagnostics
use observables
implicit none
contains
<<Process stacks: procedures>>
end submodule process_stacks_s
@ %def process_stacks_s
@
\subsection{The process entry type}
A process entry is a process object, augmented by a pointer to the
next entry. We do not need specific methods, all relevant methods are
inherited.
On higher level, processes should be prepared as process entry objects.
<<Process stacks: public>>=
public :: process_entry_t
<<Process stacks: types>>=
type, extends (process_t) :: process_entry_t
type(process_entry_t), pointer :: next => null ()
end type process_entry_t
@ %def process_entry_t
@
\subsection{The process stack type}
For easy conversion and lookup it is useful to store the filling
number in the object. The content is stored as a linked list.
The [[var_list]] component stores process-specific results, so they
can be retrieved as (pseudo) variables.
The process stack can be linked to another one. This allows us to
work with stacks of local scope.
<<Process stacks: public>>=
public :: process_stack_t
<<Process stacks: types>>=
type :: process_stack_t
integer :: n = 0
type(process_entry_t), pointer :: first => null ()
type(var_list_t), pointer :: var_list => null ()
type(process_stack_t), pointer :: next => null ()
contains
<<Process stacks: process stack: TBP>>
end type process_stack_t
@ %def process_stack_t
@ Finalize partly: deallocate the process stack and variable list
entries, but keep the variable list as an empty object. This way, the
variable list links are kept.
<<Process stacks: process stack: TBP>>=
procedure :: clear => process_stack_clear
<<Process stacks: sub interfaces>>=
module subroutine process_stack_clear (stack)
class(process_stack_t), intent(inout) :: stack
end subroutine process_stack_clear
<<Process stacks: procedures>>=
module subroutine process_stack_clear (stack)
class(process_stack_t), intent(inout) :: stack
type(process_entry_t), pointer :: process
if (associated (stack%var_list)) then
call stack%var_list%final ()
end if
do while (associated (stack%first))
process => stack%first
stack%first => process%next
call process%final ()
deallocate (process)
end do
stack%n = 0
end subroutine process_stack_clear
@ %def process_stack_clear
@ Finalizer. Clear and deallocate the variable list.
<<Process stacks: process stack: TBP>>=
procedure :: final => process_stack_final
<<Process stacks: sub interfaces>>=
module subroutine process_stack_final (object)
class(process_stack_t), intent(inout) :: object
end subroutine process_stack_final
<<Process stacks: procedures>>=
module subroutine process_stack_final (object)
class(process_stack_t), intent(inout) :: object
call object%clear ()
if (associated (object%var_list)) then
deallocate (object%var_list)
end if
end subroutine process_stack_final
@ %def process_stack_final
@ Output. The processes on the stack will be ordered LIFO, i.e.,
backwards.
<<Process stacks: process stack: TBP>>=
procedure :: write => process_stack_write
<<Process stacks: sub interfaces>>=
recursive module subroutine process_stack_write (object, unit, pacify)
class(process_stack_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacify
end subroutine process_stack_write
<<Process stacks: procedures>>=
recursive module subroutine process_stack_write (object, unit, pacify)
class(process_stack_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacify
type(process_entry_t), pointer :: process
integer :: u
u = given_output_unit (unit)
call write_separator (u, 2)
select case (object%n)
case (0)
write (u, "(1x,A)") "Process stack: [empty]"
call write_separator (u, 2)
case default
write (u, "(1x,A)") "Process stack:"
process => object%first
do while (associated (process))
call process%write (.false., u, pacify = pacify)
process => process%next
end do
end select
if (associated (object%next)) then
write (u, "(1x,A)") "[Processes from context environment:]"
call object%next%write (u, pacify)
end if
end subroutine process_stack_write
@ %def process_stack_write
@ The variable list is printed by a separate routine, since
it should be linked to the global variable list, anyway.
<<Process stacks: process stack: TBP>>=
procedure :: write_var_list => process_stack_write_var_list
<<Process stacks: sub interfaces>>=
module subroutine process_stack_write_var_list (object, unit)
class(process_stack_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine process_stack_write_var_list
<<Process stacks: procedures>>=
module subroutine process_stack_write_var_list (object, unit)
class(process_stack_t), intent(in) :: object
integer, intent(in), optional :: unit
if (associated (object%var_list)) then
call object%var_list%write (unit)
end if
end subroutine process_stack_write_var_list
@ %def process_stack_write_var_list
@ Short output.
Since this is a stack, the default output ordering for each stack will be
last-in, first-out. To enable first-in, first-out, which is more likely to be
requested, there is an optional [[fifo]] argument.
<<Process stacks: process stack: TBP>>=
procedure :: show => process_stack_show
<<Process stacks: sub interfaces>>=
recursive module subroutine process_stack_show (object, unit, fifo)
class(process_stack_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: fifo
end subroutine process_stack_show
<<Process stacks: procedures>>=
recursive module subroutine process_stack_show (object, unit, fifo)
class(process_stack_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: fifo
type(process_entry_t), pointer :: process
logical :: reverse
integer :: u, i, j
u = given_output_unit (unit)
reverse = .false.; if (present (fifo)) reverse = fifo
select case (object%n)
case (0)
case default
if (.not. reverse) then
process => object%first
do while (associated (process))
call process%show (u, verbose=.false.)
process => process%next
end do
else
do i = 1, object%n
process => object%first
do j = 1, object%n - i
process => process%next
end do
call process%show (u, verbose=.false.)
end do
end if
end select
if (associated (object%next)) call object%next%show ()
end subroutine process_stack_show
@ %def process_stack_show
@
\subsection{Link}
Link the current process stack to a global one.
<<Process stacks: process stack: TBP>>=
procedure :: link => process_stack_link
<<Process stacks: sub interfaces>>=
module subroutine process_stack_link (local_stack, global_stack)
class(process_stack_t), intent(inout) :: local_stack
type(process_stack_t), intent(in), target :: global_stack
end subroutine process_stack_link
<<Process stacks: procedures>>=
module subroutine process_stack_link (local_stack, global_stack)
class(process_stack_t), intent(inout) :: local_stack
type(process_stack_t), intent(in), target :: global_stack
local_stack%next => global_stack
end subroutine process_stack_link
@ %def process_stack_link
@ Initialize the process variable list and link the main variable list
to it.
<<Process stacks: process stack: TBP>>=
procedure :: init_var_list => process_stack_init_var_list
<<Process stacks: sub interfaces>>=
module subroutine process_stack_init_var_list (stack, var_list)
class(process_stack_t), intent(inout) :: stack
type(var_list_t), intent(inout), optional :: var_list
end subroutine process_stack_init_var_list
<<Process stacks: procedures>>=
module subroutine process_stack_init_var_list (stack, var_list)
class(process_stack_t), intent(inout) :: stack
type(var_list_t), intent(inout), optional :: var_list
allocate (stack%var_list)
if (present (var_list)) call var_list%link (stack%var_list)
end subroutine process_stack_init_var_list
@ %def process_stack_init_var_list
@ Link the process variable list to a global
variable list.
<<Process stacks: process stack: TBP>>=
procedure :: link_var_list => process_stack_link_var_list
<<Process stacks: sub interfaces>>=
module subroutine process_stack_link_var_list (stack, var_list)
class(process_stack_t), intent(inout) :: stack
type(var_list_t), intent(in), target :: var_list
end subroutine process_stack_link_var_list
<<Process stacks: procedures>>=
module subroutine process_stack_link_var_list (stack, var_list)
class(process_stack_t), intent(inout) :: stack
type(var_list_t), intent(in), target :: var_list
call stack%var_list%link (var_list)
end subroutine process_stack_link_var_list
@ %def process_stack_link_var_list
@
\subsection{Push}
We take a process pointer and push it onto the stack. The previous
pointer is nullified. Subsequently, the process is `owned' by the
stack and will be finalized when the stack is deleted.
<<Process stacks: process stack: TBP>>=
procedure :: push => process_stack_push
<<Process stacks: sub interfaces>>=
module subroutine process_stack_push (stack, process)
class(process_stack_t), intent(inout) :: stack
type(process_entry_t), intent(inout), pointer :: process
end subroutine process_stack_push
<<Process stacks: procedures>>=
module subroutine process_stack_push (stack, process)
class(process_stack_t), intent(inout) :: stack
type(process_entry_t), intent(inout), pointer :: process
process%next => stack%first
stack%first => process
process => null ()
stack%n = stack%n + 1
end subroutine process_stack_push
@ %def process_stack_push
@ Inverse: Remove the last process pointer in the list and return it.
<<Process stacks: process stack: TBP>>=
procedure :: pop_last => process_stack_pop_last
<<Process stacks: sub interfaces>>=
module subroutine process_stack_pop_last (stack, process)
class(process_stack_t), intent(inout) :: stack
type(process_entry_t), intent(inout), pointer :: process
end subroutine process_stack_pop_last
<<Process stacks: procedures>>=
module subroutine process_stack_pop_last (stack, process)
class(process_stack_t), intent(inout) :: stack
type(process_entry_t), intent(inout), pointer :: process
type(process_entry_t), pointer :: previous
integer :: i
select case (stack%n)
case (:0)
process => null ()
case (1)
process => stack%first
stack%first => null ()
stack%n = 0
case (2:)
process => stack%first
do i = 2, stack%n
previous => process
process => process%next
end do
previous%next => null ()
stack%n = stack%n - 1
end select
end subroutine process_stack_pop_last
@ %def process_stack_pop_last
@ Initialize process variables for a given process ID, without setting
values.
<<Process stacks: process stack: TBP>>=
procedure :: init_result_vars => process_stack_init_result_vars
<<Process stacks: sub interfaces>>=
module subroutine process_stack_init_result_vars (stack, id)
class(process_stack_t), intent(inout) :: stack
type(string_t), intent(in) :: id
end subroutine process_stack_init_result_vars
<<Process stacks: procedures>>=
module subroutine process_stack_init_result_vars (stack, id)
class(process_stack_t), intent(inout) :: stack
type(string_t), intent(in) :: id
call var_list_init_num_id (stack%var_list, id)
call var_list_init_process_results (stack%var_list, id)
end subroutine process_stack_init_result_vars
@ %def process_stack_init_result_vars
@ Fill process variables with values. This is executed after the
integration pass.
Note: We set only integral and error. With multiple MCI records
possible, the results for [[n_calls]], [[chi2]] etc. are not
necessarily unique. (We might set the efficiency, though.)
<<Process stacks: process stack: TBP>>=
procedure :: fill_result_vars => process_stack_fill_result_vars
<<Process stacks: sub interfaces>>=
module subroutine process_stack_fill_result_vars (stack, id)
class(process_stack_t), intent(inout) :: stack
type(string_t), intent(in) :: id
end subroutine process_stack_fill_result_vars
<<Process stacks: procedures>>=
module subroutine process_stack_fill_result_vars (stack, id)
class(process_stack_t), intent(inout) :: stack
type(string_t), intent(in) :: id
type(process_t), pointer :: process
process => stack%get_process_ptr (id)
if (associated (process)) then
call var_list_init_num_id (stack%var_list, id, process%get_num_id ())
if (process%has_integral ()) then
call var_list_init_process_results (stack%var_list, id, &
integral = process%get_integral (), &
error = process%get_error ())
end if
else
call msg_bug ("process_stack_fill_result_vars: unknown process ID")
end if
end subroutine process_stack_fill_result_vars
@ %def process_stack_fill_result_vars
@ If one of the result variables has a local image in [[var_list_local]],
update the value there as well.
<<Process stacks: process stack: TBP>>=
procedure :: update_result_vars => process_stack_update_result_vars
<<Process stacks: sub interfaces>>=
module subroutine process_stack_update_result_vars &
(stack, id, var_list_local)
class(process_stack_t), intent(inout) :: stack
type(string_t), intent(in) :: id
type(var_list_t), intent(inout) :: var_list_local
end subroutine process_stack_update_result_vars
<<Process stacks: procedures>>=
module subroutine process_stack_update_result_vars (stack, id, var_list_local)
class(process_stack_t), intent(inout) :: stack
type(string_t), intent(in) :: id
type(var_list_t), intent(inout) :: var_list_local
call update ("integral(" // id // ")")
call update ("error(" // id // ")")
contains
subroutine update (var_name)
type(string_t), intent(in) :: var_name
real(default) :: value
if (var_list_local%contains (var_name, follow_link = .false.)) then
value = stack%var_list%get_rval (var_name)
call var_list_local%set_real (var_name, value, is_known = .true.)
end if
end subroutine update
end subroutine process_stack_update_result_vars
@ %def process_stack_update_result_vars
@
\subsection{Data Access}
Tell if a process exists.
<<Process stacks: process stack: TBP>>=
procedure :: exists => process_stack_exists
<<Process stacks: sub interfaces>>=
module function process_stack_exists (stack, id) result (flag)
class(process_stack_t), intent(in) :: stack
type(string_t), intent(in) :: id
logical :: flag
end function process_stack_exists
<<Process stacks: procedures>>=
module function process_stack_exists (stack, id) result (flag)
class(process_stack_t), intent(in) :: stack
type(string_t), intent(in) :: id
logical :: flag
type(process_t), pointer :: process
process => stack%get_process_ptr (id)
flag = associated (process)
end function process_stack_exists
@ %def process_stack_exists
@ Return a pointer to a process with specific ID. Look also at a
linked stack, if necessary.
<<Process stacks: process stack: TBP>>=
procedure :: get_process_ptr => process_stack_get_process_ptr
<<Process stacks: sub interfaces>>=
recursive module function process_stack_get_process_ptr &
(stack, id) result (ptr)
class(process_stack_t), intent(in) :: stack
type(string_t), intent(in) :: id
type(process_t), pointer :: ptr
end function process_stack_get_process_ptr
<<Process stacks: procedures>>=
recursive module function process_stack_get_process_ptr &
(stack, id) result (ptr)
class(process_stack_t), intent(in) :: stack
type(string_t), intent(in) :: id
type(process_t), pointer :: ptr
type(process_entry_t), pointer :: entry
ptr => null ()
entry => stack%first
do while (associated (entry))
if (entry%get_id () == id) then
ptr => entry%process_t
return
end if
entry => entry%next
end do
if (associated (stack%next)) ptr => stack%next%get_process_ptr (id)
end function process_stack_get_process_ptr
@ %def process_stack_get_process_ptr
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[process_stacks_ut.f90]]>>=
<<File header>>
module process_stacks_ut
use unit_tests
use process_stacks_uti
<<Standard module head>>
<<Process stacks: public test>>
contains
<<Process stacks: test driver>>
end module process_stacks_ut
@ %def process_stacks_ut
@
<<[[process_stacks_uti.f90]]>>=
<<File header>>
module process_stacks_uti
<<Use strings>>
use os_interface
use sm_qcd
use models
use model_data
use variables, only: var_list_t
use process_libraries
use rng_base
use prc_test, only: prc_test_create_library
use process, only: process_t
use instances, only: process_instance_t
use processes_ut, only: prepare_test_process
use process_stacks
use rng_base_ut, only: rng_test_factory_t
<<Standard module head>>
<<Process stacks: test declarations>>
contains
<<Process stacks: tests>>
end module process_stacks_uti
@ %def process_stacks_uti
@ API: driver for the unit tests below.
<<Process stacks: public test>>=
public :: process_stacks_test
<<Process stacks: test driver>>=
subroutine process_stacks_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Process stacks: execute tests>>
end subroutine process_stacks_test
@ %def process_stacks_test
@
\subsubsection{Write an empty process stack}
The most trivial test is to write an uninitialized process stack.
<<Process stacks: execute tests>>=
call test (process_stacks_1, "process_stacks_1", &
"write an empty process stack", &
u, results)
<<Process stacks: test declarations>>=
public :: process_stacks_1
<<Process stacks: tests>>=
subroutine process_stacks_1 (u)
integer, intent(in) :: u
type(process_stack_t) :: stack
write (u, "(A)") "* Test output: process_stacks_1"
write (u, "(A)") "* Purpose: display an empty process stack"
write (u, "(A)")
call stack%write (u)
write (u, "(A)")
write (u, "(A)") "* Test output end: process_stacks_1"
end subroutine process_stacks_1
@ %def process_stacks_1
@
\subsubsection{Fill a process stack}
Fill a process stack with two (identical) processes.
<<Process stacks: execute tests>>=
call test (process_stacks_2, "process_stacks_2", &
"fill a process stack", &
u, results)
<<Process stacks: test declarations>>=
public :: process_stacks_2
<<Process stacks: tests>>=
subroutine process_stacks_2 (u)
integer, intent(in) :: u
type(process_stack_t) :: stack
type(process_library_t), target :: lib
type(string_t) :: libname
type(string_t) :: procname
type(os_data_t) :: os_data
type(model_t), target :: model
type(var_list_t) :: var_list
type(process_entry_t), pointer :: process => null ()
write (u, "(A)") "* Test output: process_stacks_2"
write (u, "(A)") "* Purpose: fill a process stack"
write (u, "(A)")
write (u, "(A)") "* Build, initialize and store two test processes"
write (u, "(A)")
libname = "process_stacks2"
procname = libname
call os_data%init ()
call prc_test_create_library (libname, lib)
call model%init_test ()
call var_list%append_string (var_str ("$run_id"))
call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
call var_list%append_int (var_str ("seed"), 0)
allocate (process)
call var_list%set_string &
(var_str ("$run_id"), var_str ("run1"), is_known=.true.)
call process%init (procname, lib, os_data, model, var_list)
call stack%push (process)
allocate (process)
call var_list%set_string &
(var_str ("$run_id"), var_str ("run2"), is_known=.true.)
call process%init (procname, lib, os_data, model, var_list)
call stack%push (process)
call stack%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call stack%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: process_stacks_2"
end subroutine process_stacks_2
@ %def process_stacks_2
@
\subsubsection{Fill a process stack}
Fill a process stack with two (identical) processes.
<<Process stacks: execute tests>>=
call test (process_stacks_3, "process_stacks_3", &
"process variables", &
u, results)
<<Process stacks: test declarations>>=
public :: process_stacks_3
<<Process stacks: tests>>=
subroutine process_stacks_3 (u)
integer, intent(in) :: u
type(process_stack_t) :: stack
type(model_t), target :: model
type(string_t) :: procname
type(process_entry_t), pointer :: process => null ()
type(process_instance_t), target :: process_instance
write (u, "(A)") "* Test output: process_stacks_3"
write (u, "(A)") "* Purpose: setup process variables"
write (u, "(A)")
write (u, "(A)") "* Initialize process variables"
write (u, "(A)")
procname = "processes_test"
call model%init_test ()
write (u, "(A)") "* Initialize process variables"
write (u, "(A)")
call stack%init_var_list ()
call stack%init_result_vars (procname)
call stack%write_var_list (u)
write (u, "(A)")
write (u, "(A)") "* Build and integrate a test process"
write (u, "(A)")
allocate (process)
call prepare_test_process (process%process_t, process_instance, model)
call process_instance%integrate (1, 1, 1000)
call process_instance%final ()
call process%final_integration (1)
call stack%push (process)
write (u, "(A)") "* Fill process variables"
write (u, "(A)")
call stack%fill_result_vars (procname)
call stack%write_var_list (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call stack%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: process_stacks_3"
end subroutine process_stacks_3
@ %def process_stacks_3
@
\subsubsection{Linked a process stack}
Fill two process stack, linked to each other.
<<Process stacks: execute tests>>=
call test (process_stacks_4, "process_stacks_4", &
"linked stacks", &
u, results)
<<Process stacks: test declarations>>=
public :: process_stacks_4
<<Process stacks: tests>>=
subroutine process_stacks_4 (u)
integer, intent(in) :: u
type(process_library_t), target :: lib
type(process_stack_t), target :: stack1, stack2
type(model_t), target :: model
type(string_t) :: libname
type(string_t) :: procname1, procname2
type(os_data_t) :: os_data
type(process_entry_t), pointer :: process => null ()
write (u, "(A)") "* Test output: process_stacks_4"
write (u, "(A)") "* Purpose: link process stacks"
write (u, "(A)")
write (u, "(A)") "* Initialize process variables"
write (u, "(A)")
libname = "process_stacks_4_lib"
procname1 = "process_stacks_4a"
procname2 = "process_stacks_4b"
call os_data%init ()
write (u, "(A)") "* Initialize first process"
write (u, "(A)")
call prc_test_create_library (procname1, lib)
call model%init_test ()
allocate (process)
call process%init (procname1, lib, os_data, model)
call stack1%push (process)
write (u, "(A)") "* Initialize second process"
write (u, "(A)")
call stack2%link (stack1)
call prc_test_create_library (procname2, lib)
allocate (process)
call process%init (procname2, lib, os_data, model)
call stack2%push (process)
write (u, "(A)") "* Show linked stacks"
write (u, "(A)")
call stack2%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call stack2%final ()
call stack1%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: process_stacks_4"
end subroutine process_stacks_4
@ %def process_stacks_4
@
Index: trunk/src/matching/matching.nw
===================================================================
--- trunk/src/matching/matching.nw (revision 8842)
+++ trunk/src/matching/matching.nw (revision 8843)
@@ -1,5711 +1,5712 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: Matching and Merging
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Matching}
\includemodulegraph{matching}
<<[[matching_base.f90]]>>=
<<File header>>
module matching_base
<<Use strings>>
use sm_qcd
use model_data
use particles
use variables
use shower_base
use instances, only: process_instance_t
use rng_base
<<Standard module head>>
<<Matching base: public>>
<<Matching base: parameters>>
<<Matching base: types>>
<<Matching base: interfaces>>
interface
<<Matching base: sub interfaces>>
end interface
end module matching_base
@ %def matching_base
@
<<[[matching_base_sub.f90]]>>=
<<File header>>
submodule (matching_base) matching_base_s
<<Use debug>>
use diagnostics
implicit none
contains
<<Matching base: procedures>>
end submodule matching_base_s
@ %def matching_base_s
@
\section{Abstract Matching Type}
A matching will need access to the [[shower]] as well as matrix elements
that we currently get over [[process_instace]]. The [[model]] is
intended for the backup [[model_hadrons]].
<<Matching base: public>>=
public :: matching_t
<<Matching base: types>>=
type, abstract :: matching_t
logical :: is_hadron_collision = .false.
type(qcd_t) :: qcd
class(shower_base_t), pointer :: shower => null ()
type(process_instance_t), pointer :: process_instance => null ()
class(model_data_t), pointer :: model => null ()
class(rng_t), allocatable :: rng
type(string_t) :: process_name
contains
<<Matching base: matching: TBP>>
end type matching_t
@ %def matching_t
@
<<Matching base: matching: TBP>>=
procedure (matching_init), deferred :: init
<<Matching base: interfaces>>=
abstract interface
subroutine matching_init (matching, var_list, process_name)
import
class(matching_t), intent(out) :: matching
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_name
end subroutine matching_init
end interface
@ %def matching_init
@ If we use a polymorphic settings type, this boilerplate wouldn't be
necessary but then we introduce [[select type]] statements all over the place.
<<default matching init>>=
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_name
if (debug_on) call msg_debug (D_MATCHING, "matching_init")
call matching%settings%init (var_list)
matching%process_name = process_name
@
<<Matching base: matching: TBP>>=
procedure (matching_write), deferred :: write
<<Matching base: interfaces>>=
abstract interface
subroutine matching_write (matching, unit)
import
class(matching_t), intent(in) :: matching
integer, intent(in), optional :: unit
end subroutine matching_write
end interface
@ %def matching_write
@
<<Matching base: matching: TBP>>=
procedure :: import_rng => matching_import_rng
<<Matching base: sub interfaces>>=
pure module subroutine matching_import_rng (matching, rng)
class(matching_t), intent(inout) :: matching
class(rng_t), allocatable, intent(inout) :: rng
end subroutine matching_import_rng
<<Matching base: procedures>>=
pure module subroutine matching_import_rng (matching, rng)
class(matching_t), intent(inout) :: matching
class(rng_t), allocatable, intent(inout) :: rng
call move_alloc (from = rng, to = matching%rng)
end subroutine matching_import_rng
@ %def matching_import_rng
@
<<Matching base: matching: TBP>>=
procedure :: connect => matching_connect
procedure :: base_connect => matching_connect
<<Matching base: sub interfaces>>=
module subroutine matching_connect &
(matching, process_instance, model, shower)
class(matching_t), intent(inout) :: matching
type(process_instance_t), intent(in), target :: process_instance
class(model_data_t), intent(in), target, optional :: model
class(shower_base_t), intent(in), target, optional :: shower
end subroutine matching_connect
<<Matching base: procedures>>=
module subroutine matching_connect (matching, process_instance, model, shower)
class(matching_t), intent(inout) :: matching
type(process_instance_t), intent(in), target :: process_instance
class(model_data_t), intent(in), target, optional :: model
class(shower_base_t), intent(in), target, optional :: shower
if (debug_on) call msg_debug (D_MATCHING, "matching_connect")
matching%process_instance => process_instance
if (present (model)) matching%model => model
if (present (shower)) matching%shower => shower
end subroutine matching_connect
@ %def matching_base_connect
@
<<Matching base: matching: TBP>>=
procedure (matching_before_shower), deferred :: before_shower
<<Matching base: interfaces>>=
abstract interface
subroutine matching_before_shower (matching, particle_set, vetoed)
import
class(matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
end subroutine matching_before_shower
end interface
@ %def matching_before_shower
@
<<Matching base: matching: TBP>>=
procedure (matching_after_shower), deferred :: after_shower
<<Matching base: interfaces>>=
abstract interface
subroutine matching_after_shower (matching, particle_set, vetoed)
import
class(matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
end subroutine matching_after_shower
end interface
@ %def matching_after_shower
@ Per default, do nothing here.
<<Matching base: matching: TBP>>=
procedure :: prepare_for_events => matching_prepare_for_events
<<Matching base: sub interfaces>>=
module subroutine matching_prepare_for_events (matching)
class(matching_t), intent(inout), target :: matching
end subroutine matching_prepare_for_events
<<Matching base: procedures>>=
module subroutine matching_prepare_for_events (matching)
class(matching_t), intent(inout), target :: matching
end subroutine matching_prepare_for_events
@ %def matching_prepare_for_events
@
<<Matching base: matching: TBP>>=
procedure :: first_event => matching_first_event
<<Matching base: sub interfaces>>=
module subroutine matching_first_event (matching)
class(matching_t), intent(inout), target :: matching
end subroutine matching_first_event
<<Matching base: procedures>>=
module subroutine matching_first_event (matching)
class(matching_t), intent(inout), target :: matching
end subroutine matching_first_event
@ %def matching_first_event
@
<<Matching base: matching: TBP>>=
procedure (matching_get_method), deferred :: get_method
<<Matching base: interfaces>>=
abstract interface
function matching_get_method (matching) result (method)
import
type(string_t) :: method
class(matching_t), intent(in) :: matching
end function matching_get_method
end interface
@ %def matching_after_shower
@
<<Matching base: matching: TBP>>=
procedure :: final => matching_final
<<Matching base: sub interfaces>>=
module subroutine matching_final (matching)
class(matching_t), intent(in) :: matching
end subroutine matching_final
<<Matching base: procedures>>=
module subroutine matching_final (matching)
class(matching_t), intent(in) :: matching
end subroutine matching_final
@ %def matching_final
@
\subsection{Matching implementations}
<<Matching base: public>>=
public :: MATCH_MLM, MATCH_CKKW, MATCH_POWHEG
<<Matching base: parameters>>=
integer, parameter :: MATCH_MLM = 1
integer, parameter :: MATCH_CKKW = 2
integer, parameter :: MATCH_POWHEG = 3
integer, parameter :: MATCH_UNDEFINED = 17
@ %def MATCH_MLM MATCH_CKKW MATCH_POWHEG MATCH_UNDEFINED
@ A dictionary
<<Matching base: public>>=
public :: matching_method
<<Matching base: interfaces>>=
interface matching_method
module procedure matching_method_of_string
module procedure matching_method_to_string
end interface
<<Matching base: sub interfaces>>=
elemental module function matching_method_of_string (string) result (i)
integer :: i
type(string_t), intent(in) :: string
end function matching_method_of_string
elemental module function matching_method_to_string (i) result (string)
type(string_t) :: string
integer, intent(in) :: i
end function matching_method_to_string
<<Matching base: procedures>>=
elemental module function matching_method_of_string (string) result (i)
integer :: i
type(string_t), intent(in) :: string
select case (char (string))
case ("MLM")
i = MATCH_MLM
case ("CKKW")
i = MATCH_CKKW
case ("POWHEG")
i = MATCH_POWHEG
case default
i = MATCH_UNDEFINED
end select
end function matching_method_of_string
elemental module function matching_method_to_string (i) result (string)
type(string_t) :: string
integer, intent(in) :: i
select case (i)
case (MATCH_MLM)
string = "MLM"
case (MATCH_CKKW)
string = "CKKW"
case (MATCH_POWHEG)
string = "POWHEG"
case default
string = "UNDEFINED"
end select
end function matching_method_to_string
@ %def matching_method
@
\section{MLM Matching}
<<[[mlm_matching.f90]]>>=
<<File header>>
module mlm_matching
<<Use kinds with double>>
<<Use strings>>
use constants
use lorentz
use particles
use variables
use matching_base
<<Standard module head>>
<<MLM matching: public>>
<<MLM matching: types>>
interface
<<MLM matching: sub interfaces>>
end interface
end module mlm_matching
@ %def mlm_matching
@
<<[[mlm_matching_sub.f90]]>>=
<<File header>>
submodule (mlm_matching) mlm_matching_s
<<Use debug>>
use io_units
use format_utils, only: write_separator
use diagnostics
use file_utils
use subevents, only: PRT_OUTGOING
use shower_base
use ktclus
implicit none
contains
<<MLM matching: procedures>>
end submodule mlm_matching_s
@ %def mlm_matching_s
@
<<MLM matching: public>>=
public :: mlm_matching_settings_t
<<MLM matching: types>>=
type :: mlm_matching_settings_t
real(default) :: mlm_Qcut_ME = one
real(default) :: mlm_Qcut_PS = one
real(default) :: mlm_ptmin, mlm_etamax, mlm_Rmin, mlm_Emin
real(default) :: mlm_ETclusfactor = 0.2_default
real(default) :: mlm_ETclusminE = five
real(default) :: mlm_etaclusfactor = one
real(default) :: mlm_Rclusfactor = one
real(default) :: mlm_Eclusfactor = one
integer :: kt_imode_hadronic = 4313
integer :: kt_imode_leptonic = 1111
integer :: mlm_nmaxMEjets = 0
contains
<<MLM matching: mlm matching settings: TBP>>
end type mlm_matching_settings_t
@ %def mlm_matching_settings_t
@
<<MLM matching: mlm matching settings: TBP>>=
procedure :: init => mlm_matching_settings_init
<<MLM matching: sub interfaces>>=
module subroutine mlm_matching_settings_init (settings, var_list)
class(mlm_matching_settings_t), intent(out) :: settings
type(var_list_t), intent(in) :: var_list
end subroutine mlm_matching_settings_init
<<MLM matching: procedures>>=
module subroutine mlm_matching_settings_init (settings, var_list)
class(mlm_matching_settings_t), intent(out) :: settings
type(var_list_t), intent(in) :: var_list
settings%mlm_Qcut_ME = &
var_list%get_rval (var_str ("mlm_Qcut_ME"))
settings%mlm_Qcut_PS = &
var_list%get_rval (var_str ("mlm_Qcut_PS"))
settings%mlm_ptmin = &
var_list%get_rval (var_str ("mlm_ptmin"))
settings%mlm_etamax = &
var_list%get_rval (var_str ("mlm_etamax"))
settings%mlm_Rmin = &
var_list%get_rval (var_str ("mlm_Rmin"))
settings%mlm_Emin = &
var_list%get_rval (var_str ("mlm_Emin"))
settings%mlm_nmaxMEjets = &
var_list%get_ival (var_str ("mlm_nmaxMEjets"))
settings%mlm_ETclusfactor = &
var_list%get_rval (var_str ("mlm_ETclusfactor"))
settings%mlm_ETclusminE = &
var_list%get_rval (var_str ("mlm_ETclusminE"))
settings%mlm_etaclusfactor = &
var_list%get_rval (var_str ("mlm_etaclusfactor"))
settings%mlm_Rclusfactor = &
var_list%get_rval (var_str ("mlm_Rclusfactor"))
settings%mlm_Eclusfactor = &
var_list%get_rval (var_str ("mlm_Eclusfactor"))
end subroutine mlm_matching_settings_init
@ %def mlm_matching_settings_init
@
<<MLM matching: mlm matching settings: TBP>>=
procedure :: write => mlm_matching_settings_write
<<MLM matching: sub interfaces>>=
module subroutine mlm_matching_settings_write (settings, unit)
class(mlm_matching_settings_t), intent(in) :: settings
integer, intent(in), optional :: unit
end subroutine mlm_matching_settings_write
<<MLM matching: procedures>>=
module subroutine mlm_matching_settings_write (settings, unit)
class(mlm_matching_settings_t), intent(in) :: settings
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(3x,A,ES19.12)") &
"mlm_Qcut_ME = ", settings%mlm_Qcut_ME
write (u, "(3x,A,ES19.12)") &
"mlm_Qcut_PS = ", settings%mlm_Qcut_PS
write (u, "(3x,A,ES19.12)") &
"mlm_ptmin = ", settings%mlm_ptmin
write (u, "(3x,A,ES19.12)") &
"mlm_etamax = ", settings%mlm_etamax
write (u, "(3x,A,ES19.12)") &
"mlm_Rmin = ", settings%mlm_Rmin
write (u, "(3x,A,ES19.12)") &
"mlm_Emin = ", settings%mlm_Emin
write (u, "(3x,A,1x,I0)") &
"mlm_nmaxMEjets = ", settings%mlm_nmaxMEjets
write (u, "(3x,A,ES19.12)") &
"mlm_ETclusfactor (D=0.2) = ", settings%mlm_ETclusfactor
write (u, "(3x,A,ES19.12)") &
"mlm_ETclusminE (D=5.0) = ", settings%mlm_ETclusminE
write (u, "(3x,A,ES19.12)") &
"mlm_etaclusfactor (D=1.0) = ", settings%mlm_etaClusfactor
write (u, "(3x,A,ES19.12)") &
"mlm_Rclusfactor (D=1.0) = ", settings%mlm_RClusfactor
write (u, "(3x,A,ES19.12)") &
"mlm_Eclusfactor (D=1.0) = ", settings%mlm_EClusfactor
end subroutine mlm_matching_settings_write
@ %def mlm_matching_settings_write
@ This is a container for the (colored) parton momenta as well as the
jet momenta.
<<MLM matching: public>>=
public :: mlm_matching_t
<<MLM matching: types>>=
type, extends (matching_t) :: mlm_matching_t
type(vector4_t), dimension(:), allocatable, public :: P_ME
type(vector4_t), dimension(:), allocatable, public :: P_PS
type(vector4_t), dimension(:), allocatable, private :: JETS_ME
type(vector4_t), dimension(:), allocatable, private :: JETS_PS
type(mlm_matching_settings_t) :: settings
contains
<<MLM matching: mlm matching: TBP>>
end type mlm_matching_t
@ %def mlm_matching_t
@
<<MLM matching: mlm matching: TBP>>=
procedure :: init => mlm_matching_init
<<MLM matching: sub interfaces>>=
module subroutine mlm_matching_init (matching, var_list, process_name)
class(mlm_matching_t), intent(out) :: matching
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_name
end subroutine mlm_matching_init
<<MLM matching: procedures>>=
module subroutine mlm_matching_init (matching, var_list, process_name)
class(mlm_matching_t), intent(out) :: matching
<<default matching init>>
end subroutine mlm_matching_init
@ %def mlm_matching_init
@
<<MLM matching: mlm matching: TBP>>=
procedure :: write => mlm_matching_write
<<MLM matching: sub interfaces>>=
module subroutine mlm_matching_write (matching, unit)
class(mlm_matching_t), intent(in) :: matching
integer, intent(in), optional :: unit
end subroutine mlm_matching_write
<<MLM matching: procedures>>=
module subroutine mlm_matching_write (matching, unit)
class(mlm_matching_t), intent(in) :: matching
integer, intent(in), optional :: unit
integer :: i, u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A)") "MLM matching:"
call matching%settings%write (u)
write (u, "(3x,A)") "Momenta of ME partons:"
if (allocated (matching%P_ME)) then
do i = 1, size (matching%P_ME)
write (u, "(4x)", advance = "no")
call vector4_write (matching%P_ME(i), unit = u)
end do
else
write (u, "(5x,A)") "[empty]"
end if
call write_separator (u)
write (u, "(3x,A)") "Momenta of ME jets:"
if (allocated (matching%JETS_ME)) then
do i = 1, size (matching%JETS_ME)
write (u, "(4x)", advance = "no")
call vector4_write (matching%JETS_ME(i), unit = u)
end do
else
write (u, "(5x,A)") "[empty]"
end if
call write_separator (u)
write(u, "(3x,A)") "Momenta of shower partons:"
if (allocated (matching%P_PS)) then
do i = 1, size (matching%P_PS)
write (u, "(4x)", advance = "no")
call vector4_write (matching%P_PS(i), unit = u)
end do
else
write (u, "(5x,A)") "[empty]"
end if
call write_separator (u)
write (u, "(3x,A)") "Momenta of shower jets:"
if (allocated (matching%JETS_PS)) then
do i = 1, size (matching%JETS_PS)
write (u, "(4x)", advance = "no")
call vector4_write (matching%JETS_PS(i), unit = u)
end do
else
write (u, "(5x,A)") "[empty]"
end if
call write_separator (u)
end subroutine mlm_matching_write
@ %def mlm_matching_write
@
<<MLM matching: mlm matching: TBP>>=
procedure :: get_method => mlm_matching_get_method
<<MLM matching: sub interfaces>>=
module function mlm_matching_get_method (matching) result (method)
type(string_t) :: method
class(mlm_matching_t), intent(in) :: matching
end function mlm_matching_get_method
<<MLM matching: procedures>>=
module function mlm_matching_get_method (matching) result (method)
type(string_t) :: method
class(mlm_matching_t), intent(in) :: matching
method = matching_method (MATCH_MLM)
end function mlm_matching_get_method
@ %def mlm_matching_get_method
@
<<MLM matching: mlm matching: TBP>>=
procedure :: before_shower => mlm_matching_before_shower
<<MLM matching: sub interfaces>>=
module subroutine mlm_matching_before_shower &
(matching, particle_set, vetoed)
class(mlm_matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
end subroutine mlm_matching_before_shower
<<MLM matching: procedures>>=
module subroutine mlm_matching_before_shower &
(matching, particle_set, vetoed)
class(mlm_matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
vetoed = .false.
end subroutine mlm_matching_before_shower
@ %def mlm_matching_before_shower
@
<<MLM matching: mlm matching: TBP>>=
procedure :: after_shower => mlm_matching_after_shower
<<MLM matching: sub interfaces>>=
module subroutine mlm_matching_after_shower (matching, particle_set, vetoed)
class(mlm_matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
end subroutine mlm_matching_after_shower
<<MLM matching: procedures>>=
module subroutine mlm_matching_after_shower (matching, particle_set, vetoed)
class(mlm_matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
if (debug_on) call msg_debug (D_MATCHING, "mlm_matching_after_shower")
call matching%shower%get_final_colored_ME_momenta (matching%P_ME)
call matching%fill_P_PS (particle_set)
!!! MLM stage 3 -> reconstruct and possibly reject
call matching%apply (vetoed)
if (debug_active (D_MATCHING)) call matching%write ()
if (allocated (matching%P_ME)) deallocate (matching%P_ME)
if (allocated (matching%P_PS)) deallocate (matching%P_PS)
if (allocated (matching%JETS_ME)) deallocate (matching%JETS_ME)
if (allocated (matching%JETS_PS)) deallocate (matching%JETS_PS)
end subroutine mlm_matching_after_shower
@ %def mlm_matching_after_shower
@ Transfer partons after parton shower to [[matching%P_PS]]
<<MLM matching: mlm matching: TBP>>=
procedure :: fill_P_PS => mlm_matching_fill_P_PS
<<MLM matching: sub interfaces>>=
module subroutine mlm_matching_fill_P_PS (matching, particle_set)
class(mlm_matching_t), intent(inout) :: matching
type(particle_set_t), intent(in) :: particle_set
end subroutine mlm_matching_fill_P_PS
<<MLM matching: procedures>>=
module subroutine mlm_matching_fill_P_PS (matching, particle_set)
class(mlm_matching_t), intent(inout) :: matching
type(particle_set_t), intent(in) :: particle_set
integer :: i, j, n_jets_PS
integer, dimension(2) :: col
type(particle_t) :: tempprt
real(double) :: eta
type(vector4_t) :: p_tmp
!!! loop over particles and extract final colored ones with eta<etamax
n_jets_PS = 0
do i = 1, particle_set%get_n_tot ()
if (signal_is_pending ()) return
tempprt = particle_set%get_particle (i)
if (tempprt%get_status () /= PRT_OUTGOING) cycle
col = tempprt%get_color ()
if (all (col == 0)) cycle
! TODO: (bcn 2015-04-28) where is the corresponding part for lepton colliders?
if (matching%is_hadron_collision) then
p_tmp = tempprt%get_momentum ()
if (energy (p_tmp) - longitudinal_part (p_tmp) < 1.E-10_default .or. &
energy (p_tmp) + longitudinal_part (p_tmp) < 1.E-10_default) then
eta = pseudorapidity (p_tmp)
else
eta = rapidity (p_tmp)
end if
if (eta > matching%settings%mlm_etaClusfactor * &
matching%settings%mlm_etamax) then
if (debug_active (D_MATCHING)) then
call msg_debug (D_MATCHING, "Rejecting this particle")
call tempprt%write ()
end if
cycle
end if
end if
n_jets_PS = n_jets_PS + 1
end do
allocate (matching%P_PS(1:n_jets_PS))
if (debug_on) call msg_debug (D_MATCHING, "n_jets_ps", n_jets_ps)
j = 1
do i = 1, particle_set%get_n_tot ()
tempprt = particle_set%get_particle (i)
if (tempprt%get_status () /= PRT_OUTGOING) cycle
col = tempprt%get_color ()
if (all(col == 0)) cycle
! TODO: (bcn 2015-04-28) where is the corresponding part for lepton colliders?
if (matching%is_hadron_collision) then
p_tmp = tempprt%get_momentum ()
if (energy (p_tmp) - longitudinal_part (p_tmp) < 1.E-10_default .or. &
energy (p_tmp) + longitudinal_part (p_tmp) < 1.E-10_default) then
eta = pseudorapidity (p_tmp)
else
eta = rapidity (p_tmp)
end if
if (eta > matching%settings%mlm_etaClusfactor * &
matching%settings%mlm_etamax) cycle
end if
matching%P_PS(j) = tempprt%get_momentum ()
j = j + 1
end do
end subroutine mlm_matching_fill_P_PS
@ %def mlm_matching_fill_P_PS
@
<<MLM matching: mlm matching: TBP>>=
procedure :: apply => mlm_matching_apply
<<MLM matching: sub interfaces>>=
module subroutine mlm_matching_apply (matching, vetoed)
class(mlm_matching_t), intent(inout) :: matching
logical, intent(out) :: vetoed
end subroutine mlm_matching_apply
<<MLM matching: procedures>>=
module subroutine mlm_matching_apply (matching, vetoed)
class(mlm_matching_t), intent(inout) :: matching
logical, intent(out) :: vetoed
integer :: i, j
integer :: n_jets_ME, n_jets_PS, n_jets_PS_atycut
real(double) :: ycut
real(double), dimension(:, :), allocatable :: PP
real(double), dimension(:), allocatable :: Y
real(double), dimension(:,:), allocatable :: P_JETS
real(double), dimension(:,:), allocatable :: P_ME
integer, dimension(:), allocatable :: JET
integer :: NJET, NSUB
integer :: imode
!!! TODO: (bcn 2014-03-26) Why is ECUT hard coded to 1?
!!! It is the denominator of the KT measure. Candidate for removal
real(double) :: ECUT = 1._double
integer :: ip1,ip2
! KTCLUS COMMON BLOCK
INTEGER NMAX,NUM,HIST
PARAMETER (NMAX=512)
DOUBLE PRECISION P,KT,KTP,KTS,ETOT,RSQ,KTLAST
COMMON /KTCOMM/ETOT,RSQ,P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX), &
KT(NMAX),KTLAST(NMAX),HIST(NMAX),NUM
vetoed = .true.
if (signal_is_pending ()) return
<<Set [[n_jets_ME/PS]] from [[matching]] (or equal zero)>>
<<Jet clustering for partons after matrix element>>
<<Jet clustering for partons after shower>>
<<Veto: too many or not enough jets after PS>>
<<Cluster ME jets with PS jets one at a time>>
vetoed = .false.
999 continue
end subroutine mlm_matching_apply
@ %def mlm_matching_apply
@
<<Set [[n_jets_ME/PS]] from [[matching]] (or equal zero)>>=
if (allocated (matching%P_ME)) then
! print *, "number of partons after ME: ", size(matching%P_ME)
n_jets_ME = size (matching%P_ME)
else
n_jets_ME = 0
end if
if (allocated (matching%p_PS)) then
! print *, "number of partons after PS: ", size(matching%p_PS)
n_jets_PS = size (matching%p_PS)
else
n_jets_PS = 0
end if
@
<<Jet clustering for partons after matrix element>>=
if (n_jets_ME > 0) then
ycut = (matching%settings%mlm_ptmin)**2
allocate (PP(1:4, 1:N_jets_ME))
do i = 1, n_jets_ME
PP(1:3,i) = matching%p_ME(i)%p(1:3)
PP(4,i) = matching%p_ME(i)%p(0)
end do
<<Set [[imode]] for lepton or hadron collisions>>
allocate (P_ME(1:4,1:n_jets_ME))
allocate (JET(1:n_jets_ME))
allocate (Y(1:n_jets_ME))
if (signal_is_pending ()) return
call KTCLUR (imode, PP, n_jets_ME, &
dble (matching%settings%mlm_Rclusfactor * matching%settings%mlm_Rmin), ECUT, y, *999)
call KTRECO (1, PP, n_jets_ME, ECUT, ycut, ycut, P_ME, JET, &
NJET, NSUB, *999)
n_jets_ME = NJET
if (NJET > 0) then
allocate (matching%JETS_ME (1:NJET))
do i = 1, NJET
matching%JETS_ME(i) = vector4_moving (REAL(P_ME(4,i), default), &
vector3_moving([REAL(P_ME(1,i), default), &
REAL(P_ME(2,i), default), REAL(P_ME(3,i), default)]))
end do
end if
deallocate (P_ME)
deallocate (JET)
deallocate (Y)
deallocate (PP)
end if
@
<<Jet clustering for partons after shower>>=
if (n_jets_PS > 0) then
ycut = (matching%settings%mlm_ptmin + max (matching%settings%mlm_ETclusminE, &
matching%settings%mlm_ETclusfactor * matching%settings%mlm_ptmin))**2
allocate (PP(1:4, 1:n_jets_PS))
do i = 1, n_jets_PS
PP(1:3,i) = matching%p_PS(i)%p(1:3)
PP(4,i) = matching%p_PS(i)%p(0)
end do
<<Set [[imode]] for lepton or hadron collisions>>
allocate (P_JETS(1:4,1:n_jets_PS))
allocate (JET(1:n_jets_PS))
allocate (Y(1:n_jets_PS))
if (signal_is_pending ()) return
call KTCLUR (imode, PP, n_jets_PS, &
dble (matching%settings%mlm_Rclusfactor * matching%settings%mlm_Rmin), &
ECUT, y, *999)
call KTRECO (1, PP, n_jets_PS, ECUT, ycut, ycut, P_JETS, JET, &
NJET, NSUB, *999)
n_jets_PS_atycut = NJET
if (n_jets_ME == matching%settings%mlm_nmaxMEjets .and. NJET > 0) then
! print *, " resetting ycut to ", Y(matching%settings%mlm_nmaxMEjets)
ycut = y(matching%settings%mlm_nmaxMEjets)
call KTRECO (1, PP, n_jets_PS, ECUT, ycut, ycut, P_JETS, JET, &
NJET, NSUB, *999)
end if
! !Sample of code for a FastJet interface
! palg = 1d0 ! 1.0d0 = kt, 0.0d0 = Cam/Aachen, -1.0d0 = anti-kt
! R = 0.7_double ! radius parameter
! f = 0.75_double ! overlap threshold
! !call fastjetppgenkt(PP,n,R,palg,P_JETS,NJET) ! KT-Algorithm
! !call fastjetsiscone(PP,n,R,f,P_JETS,NJET) ! SiSCone-Algorithm
if (NJET > 0) then
allocate (matching%JETS_PS(1:NJET))
do i = 1, NJET
matching%JETS_PS(i) = vector4_moving (REAL(P_JETS(4,i), default), &
vector3_moving([REAL(P_JETS(1,i), default), &
REAL(P_JETS(2,i), default), REAL(P_JETS(3,i), default)]))
end do
end if
deallocate (P_JETS)
deallocate (JET)
deallocate (Y)
else
n_jets_PS_atycut = 0
end if
@
<<Set [[imode]] for lepton or hadron collisions>>=
if (matching%is_hadron_collision) then
imode = matching%settings%kt_imode_hadronic
else
imode = matching%settings%kt_imode_leptonic
end if
@
<<Veto: too many or not enough jets after PS>>=
if (n_jets_PS_atycut < n_jets_ME) then
! print *, "DISCARDING: Not enough PS jets: ", n_jets_PS_atycut
return
end if
if (n_jets_PS_atycut > n_jets_ME .and. n_jets_ME /= matching%settings%mlm_nmaxMEjets) then
! print *, "DISCARDING: Too many PS jets: ", n_jets_PS_atycut
return
end if
@
<<Cluster ME jets with PS jets one at a time>>=
if (allocated(matching%JETS_PS)) then
! print *, "number of jets after PS: ", size(matching%JETS_PS)
n_jets_PS = size (matching%JETS_PS)
else
n_jets_PS = 0
end if
if (n_jets_ME > 0 .and. n_jets_PS > 0) then
n_jets_PS = size (matching%JETS_PS)
if (allocated (PP)) deallocate(PP)
allocate (PP(1:4, 1:n_jets_PS + 1))
do i = 1, n_jets_PS
if (signal_is_pending ()) return
PP(1:3,i) = matching%JETS_PS(i)%p(1:3)
PP(4,i) = matching%JETS_PS(i)%p(0)
end do
if (allocated (Y)) deallocate(Y)
allocate (Y(1:n_jets_PS + 1))
y = zero
do i = 1, n_jets_ME
PP(1:3,n_jets_PS + 2 - i) = matching%JETS_ME(i)%p(1:3)
PP(4,n_jets_PS + 2 - i) = matching%JETS_ME(i)%p(0)
!!! This makes more sense than hardcoding
! call KTCLUS (4313, PP, (n_jets_PS + 2 - i), 1.0_double, Y, *999)
call KTCLUR (imode, PP, (n_jets_PS + 2 - i), &
dble (matching%settings%mlm_Rclusfactor * matching%settings%mlm_Rmin), &
ECUT, y, *999)
if (0.99 * y(n_jets_PS + 1 - (i - 1)).gt.ycut) then
! print *, "DISCARDING: Jet ", i, " not clusterd"
return
end if
!!! search for and remove PS jet clustered with ME Jet
ip1 = HIST(n_jets_PS + 2 - i) / NMAX
ip2 = mod(hist(n_jets_PS + 2 - i), NMAX)
if ((ip2 /= n_jets_PS + 2 - i) .or. (ip1 <= 0)) then
! print *, "DISCARDING: Jet ", i, " not clustered ", ip1, ip2, &
! hist(n_jets_PS + 2 - i)
return
else
! print *, "PARTON clustered", ip1, ip2, hist(n_jets_PS + 2 - i)
PP(:,IP1) = zero
do j = IP1, n_jets_PS - i
PP(:, j) = PP(:,j + 1)
end do
end if
end do
end if
@
\section{CKKW matching}
This module contains the CKKW matching.
The type [[ckkw_pseudo_shower_weights_t]] gives the (relative) weights
for different clusterings of the final particles, as given in Eq.~(2.7) of
hep-ph/0503281v1. Each particle has a binary labelling (power of 2)
(first particle = 1, second particle = 2, third particle = 4,
...). Each recombination therefore corresponds to an integer, that is
not a power of 2. Fur multiple subsequent recombinations, no different
weights for different sequences of clustering are stored. It is
assumed that the weight of a multiply recombined state is a
combination of the states with one fewer recombination and that these
states' contributions are proportional to their weights. For a $2->n$
event, the weights array thus has the size $2^{(2 + n) - 1}$. The
[[weights_by_type]] array gives the weights depending on the type of
the particle, the first index is the same as for weights, the second
index gives the type of the new mother particle:
\begin{itemize}
\item[0:] uncolored ($\gamma$, $Z$, $W$, Higgs)
\item[1:] colored (quark)
\item[2:] gluon
\item[3:] squark
\item[4:] gluino
\end{itemize}
[[alphaS]] gives the value for $alpha_s$ used in the generation of the
matrix element. This is needed for the reweighting using the values
for a running $alpha_s$ at the scales of the clusterings.
<<[[ckkw_matching.f90]]>>=
<<File header>>
module ckkw_matching
<<Use kinds with double>>
<<Use strings>>
use constants
use lorentz
use particles
use rng_base
use shower_base
use shower_partons
use variables
use matching_base
<<Standard module head>>
<<CKKW matching: public>>
<<CKKW matching: types>>
interface
<<CKKW matching: sub interfaces>>
end interface
end module ckkw_matching
@ %def ckkw_matching
@
<<[[ckkw_matching_sub.f90]]>>=
<<File header>>
submodule (ckkw_matching) ckkw_matching_s
<<Use debug>>
use io_units
use format_utils, only: write_separator
use diagnostics
use physics_defs
use shower_core
implicit none
contains
<<CKKW matching: procedures>>
end submodule ckkw_matching_s
@ %def ckkw_matching_s
@ The fundamental CKKW matching parameter are defined here:
<<CKKW matching: public>>=
public :: ckkw_matching_settings_t
<<CKKW matching: types>>=
type :: ckkw_matching_settings_t
real(default) :: alphaS = 0.118_default
real(default) :: Qmin = one
integer :: n_max_jets = 0
contains
<<CKKW matching: ckkw matching settings: TBP>>
end type ckkw_matching_settings_t
@ %def ckkw_matching_settings_t
@ This is empty for the moment.
<<CKKW matching: ckkw matching settings: TBP>>=
procedure :: init => ckkw_matching_settings_init
<<CKKW matching: sub interfaces>>=
module subroutine ckkw_matching_settings_init (settings, var_list)
class(ckkw_matching_settings_t), intent(out) :: settings
type(var_list_t), intent(in) :: var_list
end subroutine ckkw_matching_settings_init
<<CKKW matching: procedures>>=
module subroutine ckkw_matching_settings_init (settings, var_list)
class(ckkw_matching_settings_t), intent(out) :: settings
type(var_list_t), intent(in) :: var_list
settings%alphaS = 1.0_default
settings%Qmin = 1.0_default
settings%n_max_jets = 3
end subroutine ckkw_matching_settings_init
@ %def ckkw_matching_settings_init
@
<<CKKW matching: ckkw matching settings: TBP>>=
procedure :: write => ckkw_matching_settings_write
<<CKKW matching: sub interfaces>>=
module subroutine ckkw_matching_settings_write (settings, unit)
class(ckkw_matching_settings_t), intent(in) :: settings
integer, intent(in), optional :: unit
end subroutine ckkw_matching_settings_write
<<CKKW matching: procedures>>=
module subroutine ckkw_matching_settings_write (settings, unit)
class(ckkw_matching_settings_t), intent(in) :: settings
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A)") "CKKW matching settings:"
call write_separator (u)
write (u, "(3x,A,1x,ES19.12)") &
"alphaS = ", settings%alphaS
write (u, "(3x,A,1x,ES19.12)") &
"Qmin = ", settings%Qmin
write (u, "(3x,A,1x,I0)") &
"n_max_jets = ", settings%n_max_jets
end subroutine ckkw_matching_settings_write
@ %def ckkw_matching_settings_write
@
<<CKKW matching: public>>=
public :: ckkw_pseudo_shower_weights_t
<<CKKW matching: types>>=
type :: ckkw_pseudo_shower_weights_t
real(default) :: alphaS
real(default), dimension(:), allocatable :: weights
real(default), dimension(:,:), allocatable :: weights_by_type
contains
<<CKKW matching: ckkw pseudo shower weights: TBP>>
end type ckkw_pseudo_shower_weights_t
@ %def ckkw_pseudo_shower_weights_t
@
<<CKKW matching: ckkw pseudo shower weights: TBP>>=
procedure :: init => ckkw_pseudo_shower_weights_init
<<CKKW matching: sub interfaces>>=
module subroutine ckkw_pseudo_shower_weights_init (weights)
class(ckkw_pseudo_shower_weights_t), intent(out) :: weights
end subroutine ckkw_pseudo_shower_weights_init
<<CKKW matching: procedures>>=
module subroutine ckkw_pseudo_shower_weights_init (weights)
class(ckkw_pseudo_shower_weights_t), intent(out) :: weights
weights%alphaS = zero
end subroutine ckkw_pseudo_shower_weights_init
@ %def ckkw_pseudo_shower_weights_init
@
<<CKKW matching: ckkw pseudo shower weights: TBP>>=
procedure :: write => ckkw_pseudo_shower_weights_write
<<CKKW matching: sub interfaces>>=
module subroutine ckkw_pseudo_shower_weights_write (weights, unit)
class(ckkw_pseudo_shower_weights_t), intent(in) :: weights
integer, intent(in), optional :: unit
end subroutine ckkw_pseudo_shower_weights_write
<<CKKW matching: procedures>>=
module subroutine ckkw_pseudo_shower_weights_write (weights, unit)
class(ckkw_pseudo_shower_weights_t), intent(in) :: weights
integer, intent(in), optional :: unit
integer :: s, i, u
u = given_output_unit (unit); if (u < 0) return
s = size (weights%weights)
write (u, "(1x,A)") "CKKW (pseudo) shower weights: "
do i = 1, s
write (u, "(3x,I0,2(ES19.12))") i, weights%weights(i), &
weights%weights_by_type(i,:)
end do
write (u, "(3x,A,1x,I0)") "alphaS =", weights%alphaS
end subroutine ckkw_pseudo_shower_weights_write
@ %def ckkw_pseudo_shower_weights_write
@ Generate fake ckkw weights. This can be dropped, once information
from the matrix element generation is available.
<<CKKW matching: ckkw pseudo shower weights: TBP>>=
procedure :: fake => ckkw_pseudo_shower_weights_fake
<<CKKW matching: sub interfaces>>=
pure module subroutine ckkw_pseudo_shower_weights_fake &
(weights, particle_set)
class(ckkw_pseudo_shower_weights_t), intent(inout) :: weights
type(particle_set_t), intent(in) :: particle_set
end subroutine ckkw_pseudo_shower_weights_fake
<<CKKW matching: procedures>>=
pure module subroutine ckkw_pseudo_shower_weights_fake (weights, particle_set)
class(ckkw_pseudo_shower_weights_t), intent(inout) :: weights
type(particle_set_t), intent(in) :: particle_set
integer :: i, j, n
type(vector4_t) :: momentum
n = 2**particle_set%n_tot
if (allocated (weights%weights)) then
deallocate (weights%weights)
end if
allocate (weights%weights (1:n))
do i = 1, n
momentum = vector4_null
do j = 1, particle_set%n_tot
if (btest (i,j-1)) then
momentum = momentum + particle_set%prt(j)%p
end if
end do
if (momentum**1 > 0.0) then
weights%weights(i) = 1.0 / (momentum**2)
end if
end do
! equally distribute the weights by type
if (allocated (weights%weights_by_type)) then
deallocate (weights%weights_by_type)
end if
allocate (weights%weights_by_type (1:n, 0:4))
do i = 1, n
do j = 0, 4
weights%weights_by_type(i,j) = 0.2 * weights%weights(i)
end do
end do
end subroutine ckkw_pseudo_shower_weights_fake
@ %def ckkw_pseudo_shower_weights_fake
@
<<CKKW matching: public>>=
public :: ckkw_matching_t
<<CKKW matching: types>>=
type, extends (matching_t) :: ckkw_matching_t
type(ckkw_matching_settings_t) :: settings
type(ckkw_pseudo_shower_weights_t) :: weights
contains
<<CKKW matching: ckkw matching: TBP>>
end type ckkw_matching_t
@ %def ckkw_matching_t
@
<<CKKW matching: ckkw matching: TBP>>=
procedure :: init => ckkw_matching_init
<<CKKW matching: sub interfaces>>=
module subroutine ckkw_matching_init (matching, var_list, process_name)
class(ckkw_matching_t), intent(out) :: matching
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_name
end subroutine ckkw_matching_init
<<CKKW matching: procedures>>=
module subroutine ckkw_matching_init (matching, var_list, process_name)
class(ckkw_matching_t), intent(out) :: matching
<<default matching init>>
end subroutine ckkw_matching_init
@ %def ckkw_matching_init
@
<<CKKW matching: ckkw matching: TBP>>=
procedure :: write => ckkw_matching_write
<<CKKW matching: sub interfaces>>=
module subroutine ckkw_matching_write (matching, unit)
class(ckkw_matching_t), intent(in) :: matching
integer, intent(in), optional :: unit
end subroutine ckkw_matching_write
<<CKKW matching: procedures>>=
module subroutine ckkw_matching_write (matching, unit)
class(ckkw_matching_t), intent(in) :: matching
integer, intent(in), optional :: unit
call matching%settings%write (unit)
call matching%weights%write (unit)
end subroutine ckkw_matching_write
@ %def ckkw_matching_write
@
<<CKKW matching: ckkw matching: TBP>>=
procedure :: get_method => ckkw_matching_get_method
<<CKKW matching: sub interfaces>>=
module function ckkw_matching_get_method (matching) result (method)
type(string_t) :: method
class(ckkw_matching_t), intent(in) :: matching
end function ckkw_matching_get_method
<<CKKW matching: procedures>>=
module function ckkw_matching_get_method (matching) result (method)
type(string_t) :: method
class(ckkw_matching_t), intent(in) :: matching
method = matching_method (MATCH_CKKW)
end function ckkw_matching_get_method
@ %def ckkw_matching_get_method
@
<<CKKW matching: ckkw matching: TBP>>=
procedure :: before_shower => ckkw_matching_before_shower
<<CKKW matching: sub interfaces>>=
module subroutine ckkw_matching_before_shower &
(matching, particle_set, vetoed)
class(ckkw_matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
end subroutine ckkw_matching_before_shower
<<CKKW matching: procedures>>=
module subroutine ckkw_matching_before_shower &
(matching, particle_set, vetoed)
class(ckkw_matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
call matching%weights%init ()
call matching%weights%fake (particle_set)
select type (shower => matching%shower)
type is (shower_t)
call ckkw_matching_apply (shower%partons, &
matching%settings, &
matching%weights, matching%rng, vetoed)
class default
call msg_bug ("CKKW matching only works with WHIZARD shower.")
end select
end subroutine ckkw_matching_before_shower
@ %def ckkw_matching_before_shower
@
<<CKKW matching: public>>=
public :: ckkw_matching_apply
<<CKKW matching: sub interfaces>>=
module subroutine ckkw_matching_apply &
(partons, settings, weights, rng, vetoed)
type(parton_pointer_t), dimension(:), intent(inout), allocatable :: &
partons
type(ckkw_matching_settings_t), intent(in) :: settings
type(ckkw_pseudo_shower_weights_t), intent(in) :: weights
class(rng_t), intent(inout), allocatable :: rng
logical, intent(out) :: vetoed
end subroutine ckkw_matching_apply
<<CKKW matching: procedures>>=
module subroutine ckkw_matching_apply &
(partons, settings, weights, rng, vetoed)
type(parton_pointer_t), dimension(:), intent(inout), allocatable :: &
partons
type(ckkw_matching_settings_t), intent(in) :: settings
type(ckkw_pseudo_shower_weights_t), intent(in) :: weights
class(rng_t), intent(inout), allocatable :: rng
logical, intent(out) :: vetoed
real(default), dimension(:), allocatable :: scales
real(double) :: weight, sf
real(default) :: rand
integer :: i, n_partons
if (signal_is_pending ()) return
weight = one
n_partons = size (partons)
do i = 1, n_partons
call partons(i)%p%write ()
end do
!!! the pseudo parton shower is already simulated by shower_add_interaction
!!! get the respective clustering scales
allocate (scales (1:n_partons))
do i = 1, n_partons
if (.not. associated (partons(i)%p)) cycle
if (partons(i)%p%type == INTERNAL) then
scales(i) = two * min (partons(i)%p%child1%momentum%p(0), &
partons(i)%p%child2%momentum%p(0))**2 * &
(1.0 - (space_part (partons(i)%p%child1%momentum) * &
space_part (partons(i)%p%child2%momentum)) / &
(space_part (partons(i)%p%child1%momentum)**1 * &
space_part (partons(i)%p%child2%momentum)**1))
scales(i) = sqrt (scales(i))
partons(i)%p%ckkwscale = scales(i)
print *, scales(i)
end if
end do
print *, " scales finished"
!!! if (highest multiplicity) -> reweight with PDF(mu_F) / PDF(mu_cut)
do i = 1, n_partons
call partons(i)%p%write ()
end do
!!! Reweight and possibly veto the whole event
!!! calculate the relative alpha_S weight
!! calculate the Sudakov weights for internal lines
!! calculate the Sudakov weights for external lines
do i = 1, n_partons
if (signal_is_pending ()) return
if (.not. associated (partons(i)%p)) cycle
if (partons(i)%p%type == INTERNAL) then
!!! get type
!!! check that all particles involved are colored
if ((partons(i)%p%is_colored () .or. &
partons(i)%p%ckkwtype > 0) .and. &
(partons(i)%p%child1%is_colored () .or. &
partons(i)%p%child1%ckkwtype > 0) .and. &
(partons(i)%p%child1%is_colored () .or. &
partons(i)%p%child1%ckkwtype > 0)) then
print *, "reweight with alphaS(" , partons(i)%p%ckkwscale, &
") for particle ", partons(i)%p%nr
if (partons(i)%p%belongstoFSR) then
print *, "FSR"
weight = weight * D_alpha_s_fsr (partons(i)%p%ckkwscale**2, &
partons(i)%p%settings) / settings%alphas
else
print *, "ISR"
weight = weight * &
D_alpha_s_isr (partons(i)%p%ckkwscale**2, &
partons(i)%p%settings) / settings%alphas
end if
else
print *, "no reweight with alphaS for ", partons(i)%p%nr
end if
if (partons(i)%p%child1%type == INTERNAL) then
print *, "internal line from ", &
partons(i)%p%child1%ckkwscale, &
" to ", partons(i)%p%ckkwscale, &
" for type ", partons(i)%p%child1%ckkwtype
if (partons(i)%p%child1%ckkwtype == 0) then
sf = 1.0
else if (partons(i)%p%child1%ckkwtype == 1) then
sf = SudakovQ (partons(i)%p%child1%ckkwscale, &
partons(i)%p%ckkwscale, &
partons(i)%p%settings, .true., rng)
print *, "SFQ = ", sf
else if (partons(i)%p%child1%ckkwtype == 2) then
sf = SudakovG (partons(i)%p%child1%ckkwscale, &
partons(i)%p%ckkwscale, &
partons(i)%p%settings, .true., rng)
print *, "SFG = ", sf
else
print *, "SUSY not yet implemented"
end if
weight = weight * min (one, sf)
else
print *, "external line from ", settings%Qmin, &
partons(i)%p%ckkwscale
if (partons(i)%p%child1%is_quark ()) then
sf = SudakovQ (settings%Qmin, &
partons(i)%p%ckkwscale, &
partons(i)%p%settings, .true., rng)
print *, "SFQ = ", sf
else if (partons(i)%p%child1%is_gluon ()) then
sf = SudakovG (settings%Qmin, &
partons(i)%p%ckkwscale, &
partons(i)%p%settings, .true., rng)
print *, "SFG = ", sf
else
print *, "not yet implemented (", &
partons(i)%p%child2%type, ")"
sf = one
end if
weight = weight * min (one, sf)
end if
if (partons(i)%p%child2%type == INTERNAL) then
print *, "internal line from ", partons(i)%p%child2%ckkwscale, &
" to ", partons(i)%p%ckkwscale, &
" for type ", partons(i)%p%child2%ckkwtype
if (partons(i)%p%child2%ckkwtype == 0) then
sf = 1.0
else if (partons(i)%p%child2%ckkwtype == 1) then
sf = SudakovQ (partons(i)%p%child2%ckkwscale, &
partons(i)%p%ckkwscale, &
partons(i)%p%settings, .true., rng)
print *, "SFQ = ", sf
else if (partons(i)%p%child2%ckkwtype == 2) then
sf = SudakovG (partons(i)%p%child2%ckkwscale, &
partons(i)%p%ckkwscale, &
partons(i)%p%settings, .true., rng)
print *, "SFG = ", sf
else
print *, "SUSY not yet implemented"
end if
weight = weight * min (one, sf)
else
print *, "external line from ", settings%Qmin, &
partons(i)%p%ckkwscale
if (partons(i)%p%child2%is_quark ()) then
sf = SudakovQ (settings%Qmin, &
partons(i)%p%ckkwscale, &
partons(i)%p%settings, .true., rng)
print *, "SFQ = ", sf
else if (partons(i)%p%child2%is_gluon ()) then
sf = SudakovG (settings%Qmin, &
partons(i)%p%ckkwscale, &
partons(i)%p%settings, .true., rng)
print *, "SFG = ", sf
else
print *, "not yet implemented (", &
partons(i)%p%child2%type, ")"
sf = one
end if
weight = weight * min (one, sf)
end if
end if
end do
call rng%generate (rand)
print *, "final weight: ", weight
!!!!!!! WRONG
vetoed = .false.
! vetoed = (rand > weight)
if (vetoed) then
return
end if
!!! finally perform the parton shower
!!! veto emissions that are too hard
deallocate (scales)
end subroutine ckkw_matching_apply
@ %def ckkw_matching_apply
@
@
<<CKKW matching: ckkw matching: TBP>>=
procedure :: after_shower => ckkw_matching_after_shower
<<CKKW matching: sub interfaces>>=
module subroutine ckkw_matching_after_shower &
(matching, particle_set, vetoed)
class(ckkw_matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
end subroutine ckkw_matching_after_shower
<<CKKW matching: procedures>>=
module subroutine ckkw_matching_after_shower (matching, particle_set, vetoed)
class(ckkw_matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
vetoed = .false.
end subroutine ckkw_matching_after_shower
@ %def ckkw_matching_after_shower
<<CKKW matching: procedures>>=
function GammaQ (smallq, largeq, settings, fsr) result (gamma)
real(default), intent(in) :: smallq, largeq
type(shower_settings_t), intent(in) :: settings
logical, intent(in) :: fsr
real(default) :: gamma
gamma = (8._default / three) / (pi * smallq)
gamma = gamma * (log(largeq / smallq) - 0.75)
if (fsr) then
gamma = gamma * D_alpha_s_fsr (smallq**2, settings)
else
gamma = gamma * D_alpha_s_isr (smallq**2, settings)
end if
end function GammaQ
@ %def GammaQ
@
<<CKKW matching: procedures>>=
function GammaG (smallq, largeq, settings, fsr) result (gamma)
real(default), intent(in) :: smallq, largeq
type(shower_settings_t), intent(in) :: settings
logical, intent(in) :: fsr
real(default) :: gamma
gamma = 6._default / (pi * smallq)
gamma = gamma *( log(largeq / smallq) - 11.0 / 12.0)
if (fsr) then
gamma = gamma * D_alpha_s_fsr (smallq**2, settings)
else
gamma = gamma * D_alpha_s_isr (smallq**2, settings)
end if
end function GammaG
@ %def GammaG
@
<<CKKW matching: procedures>>=
function GammaF (smallq, settings, fsr) result (gamma)
real(default), intent(in) :: smallq
type(shower_settings_t), intent(in) :: settings
logical, intent(in) :: fsr
real(default) :: gamma
gamma = number_of_flavors (smallq, settings%max_n_flavors, &
settings%min_virtuality) / (three * pi * smallq)
if (fsr) then
gamma = gamma * D_alpha_s_fsr (smallq**2, settings)
else
gamma = gamma * D_alpha_s_isr (smallq**2, settings)
end if
end function GammaF
@ %def GammaF
@
<<CKKW matching: procedures>>=
function SudakovQ (Q1, Q, settings, fsr, rng) result (sf)
real(default), intent(in) :: Q1, Q
type(shower_settings_t), intent(in) :: settings
class(rng_t), intent(inout), allocatable :: rng
logical, intent(in) :: fsr
real(default) :: sf
real(default) :: integral
integer, parameter :: NTRIES = 100
integer :: i
real(default) :: rand
integral = zero
do i = 1, NTRIES
call rng%generate (rand)
integral = integral + GammaQ (Q1 + rand * (Q - Q1), Q, settings, fsr)
end do
integral = integral / NTRIES
sf = exp (-integral)
end function SudakovQ
@ %def SudakovQ
@
<<CKKW matching: procedures>>=
function SudakovG (Q1, Q, settings, fsr, rng) result (sf)
real(default), intent(in) :: Q1, Q
type(shower_settings_t), intent(in) :: settings
logical, intent(in) :: fsr
real(default) :: sf
real(default) :: integral
class(rng_t), intent(inout), allocatable :: rng
integer, parameter :: NTRIES = 100
integer :: i
real(default) :: rand
integral = zero
do i = 1, NTRIES
call rng%generate (rand)
integral = integral + &
GammaG (Q1 + rand * (Q - Q1), Q, settings, fsr) + &
GammaF (Q1 + rand * (Q - Q1), settings, fsr)
end do
integral = integral / NTRIES
sf = exp (-integral)
end function SudakovG
@ %def SudakovG
@
\section{POWHEG}
This module generates radiation according to the POWHEG Sudakov form factor
\begin{equation}
\Delta^{f_b} (\Phi_n, p_\text{T}) = \prod_{\alpha_r \in \{\alpha_r |f_b \}}
\Delta^{f_b}_{\alpha_r} (\Phi_n,
p_\text{T}),
\end{equation}
with
\begin{equation}
\Delta^{f_b}_{\alpha_r} (\Phi_n, p_\text{T}) = \exp \left\{ - \left[ \int d
\Phi_{\text{rad}} \,\frac{R (\Phi_{n+1})}{B^{f_b} (\Phi_n)}
\,\theta( k_\text{T} (\Phi_{n+1}) - p_\text{T}) \right]^{\bar{\bf \Phi}_n^{\alpha_r} =
\Phi_n}_{\alpha_r} \right\}
\end{equation}
We expect that an underlying Born flavor structure $f_b$ has been
generated with a probability proportional to its contribution to the
$\tilde B$ at the given kinematic point.
<<[[powheg_matching.f90]]>>=
<<File header>>
module powheg_matching
use, intrinsic :: iso_fortran_env
<<Use kinds with double>>
<<Use strings>>
use diagnostics
use constants, only: ZERO, ONE, TWO, THREE, FOUR, FIVE, TINY_07, PI, TWOPI
use pdf, only: pdf_data_t
use lorentz
use phs_points, only: assignment(=), operator(*)
use sm_qcd, only: qcd_t, alpha_qcd_from_scale_t, alpha_qcd_from_lambda_t
use particles
use grids
use solver
use rng_base
use variables
use phs_fks, only: phs_fks_generator_t, compute_dalitz_bounds, beta_emitter
use phs_fks, only: phs_point_set_t, phs_identifier_t, phs_fks_t
use phs_fks, only: get_xi_max_isr
use phs_fks, only: I_XI, I_Y, I_PLUS, I_MINUS, UBF_FSR_SIMPLE, UBF_FSR_MASSIVE, UBF_FSR_MASSLESS_RECOIL, UBF_ISR
use matching_base
use instances, only: process_instance_t, process_instance_hook_t
use pcm, only: pcm_nlo_t, pcm_nlo_workspace_t
<<Standard module head>>
<<POWHEG matching: public>>
<<POWHEG matching: types>>
<<POWHEG matching: interfaces>>
interface
<<POWHEG matching: sub interfaces>>
end interface
contains
<<POWHEG matching: main procedures>>
end module powheg_matching
@ %def powheg_matching
@
<<[[powheg_matching_sub.f90]]>>=
<<File header>>
submodule (powheg_matching) powheg_matching_s
<<Use mpi f08>>
<<Use debug>>
use io_units, only: given_output_unit, free_unit
use format_utils, only: write_separator
use format_defs, only: FMT_16, FMT_19
use string_utils, only: str
use numeric_utils
use os_interface, only: os_file_exist
use physics_defs, only: CA, BORN, NLO_REAL, MZ_REF
use pdg_arrays, only: is_gluon, is_quark
use sf_lhapdf, only: alpha_qcd_lhapdf_t
use sm_physics, only: Li2, coeff_b0, lambda_qcd
use subevents, only: PRT_INCOMING, PRT_OUTGOING
use colors
use process_config, only: COMP_REAL_FIN
use prc_external, only: prc_external_state_t
use prc_omega, only: omega_state_t
implicit none
contains
<<POWHEG matching: procedures>>
end submodule powheg_matching_s
@ %def powheg_matching_s
@
\subsection{Base types for settings and data}
[[lambda]] is the lowest scale $\Lambda^(5)_{\bar{\text{MS}}}$
where the radiation $\alpha_s^\text{rad}$ is still larger than
the true $\alpha_s$. We relate $\alpha_s^\text{rad}$ and
$\alpha_s^\text{true}$ at the scale $2\Lambda^(5)_{\bar{\text{MS}}}$.
<<POWHEG matching: public>>=
public :: powheg_settings_t
<<POWHEG matching: types>>=
type :: powheg_settings_t
real(default) :: pt2_min = zero
real(default) :: lambda = zero
integer :: size_grid_xi = 0
integer :: size_grid_y = 0
integer :: upper_bound_func_type = UBF_FSR_SIMPLE
logical :: test_sudakov = .false.
logical :: disable_sudakov = .false.
logical :: singular_jacobian = .false.
contains
<<POWHEG matching: powheg settings: TBP>>
end type powheg_settings_t
@ %def powheg_settings_t
@
<<POWHEG matching: powheg settings: TBP>>=
procedure :: init => powheg_settings_init
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_settings_init (settings, var_list)
class(powheg_settings_t), intent(out) :: settings
type(var_list_t), intent(in) :: var_list
end subroutine powheg_settings_init
<<POWHEG matching: procedures>>=
module subroutine powheg_settings_init (settings, var_list)
class(powheg_settings_t), intent(out) :: settings
type(var_list_t), intent(in) :: var_list
settings%pt2_min = &
var_list%get_rval (var_str ("powheg_pt_min"))**2
settings%size_grid_xi = &
var_list%get_ival (var_str ("powheg_grid_size_xi"))
settings%size_grid_y = &
var_list%get_ival (var_str ("powheg_grid_size_y"))
settings%lambda = var_list%get_rval (var_str ("powheg_lambda"))
settings%singular_jacobian = &
var_list%get_lval (var_str ("?powheg_use_singular_jacobian"))
settings%test_sudakov = &
var_list%get_lval (var_str ("?powheg_test_sudakov"))
settings%disable_sudakov = &
var_list%get_lval (var_str ("?powheg_disable_sudakov"))
end subroutine powheg_settings_init
@ %def powheg_settings_init
@
<<POWHEG matching: powheg settings: TBP>>=
procedure :: write => powheg_settings_write
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_settings_write (powheg_settings, unit)
class(powheg_settings_t), intent(in) :: powheg_settings
integer, intent(in), optional :: unit
end subroutine powheg_settings_write
<<POWHEG matching: procedures>>=
module subroutine powheg_settings_write (powheg_settings, unit)
class(powheg_settings_t), intent(in) :: powheg_settings
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1X,A)") "POWHEG settings:"
write (u, "(3X,A," // FMT_16 //")") "pt2_min = ", powheg_settings%pt2_min
write (u, "(3X,A," // FMT_16 //")") "lambda = ", powheg_settings%lambda
write (u, "(3X,A,I12)") "size_grid_xi = ", powheg_settings%size_grid_xi
write (u, "(3X,A,I12)") "size_grid_y = ", powheg_settings%size_grid_y
write (u, "(3X,A,I12)") "upper_bound_func_type = ", powheg_settings%upper_bound_func_type
end subroutine powheg_settings_write
@ %def powheg_settings_write
@
<<POWHEG matching: public>>=
public :: radiation_t
<<POWHEG matching: types>>=
type :: radiation_t
real(default) :: xi, y, phi, pt2
integer :: alr
logical :: valid = .false.
contains
<<POWHEG matching: radiation: TBP>>
end type radiation_t
@ %def radiation_t
@
<<POWHEG matching: radiation: TBP>>=
procedure :: write => radiation_write
<<POWHEG matching: sub interfaces>>=
module subroutine radiation_write (radiation, unit)
class(radiation_t), intent(in) :: radiation
integer, intent(in), optional :: unit
end subroutine radiation_write
<<POWHEG matching: procedures>>=
module subroutine radiation_write (radiation, unit)
class(radiation_t), intent(in) :: radiation
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1X, A)") "Radiation:"
write (u, "(3X, A," // FMT_16 // ")") "xi = ", radiation%xi
write (u, "(3X, A," // FMT_16 // ")") "y = ", radiation%y
write (u, "(3X, A," // FMT_16 // ")") "phi = ", radiation%phi
write (u, "(3X, A," // FMT_16 // ")") "pt2 = ", radiation%pt2
write (u, "(3X, A, I12)") "alr = ", radiation%alr
end subroutine radiation_write
@ %def radiation_write
@ [[lambda2_gen]] is the scale used in the (log integrated) upper bounding
functions. It is not equivalent to [[lambda5MSB]] which is a reference
scale for the $\alpha_s$ evolution.
<<POWHEG matching: public>>=
public :: process_deps_t
<<POWHEG matching: types>>=
type :: process_deps_t
real(default) :: lambda2_gen, lambda5MSB, sqrts
integer :: n_alr
integer :: alpha_power, alphas_power
logical :: lab_is_cm = .true.
type(pdf_data_t) :: pdf_data
type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers
integer, dimension(:), allocatable :: alr_to_i_phs
integer :: i_term_born
integer, dimension(:), allocatable :: i_term_real
contains
<<POWHEG matching: process deps: TBP>>
end type process_deps_t
@ %def process_deps_t
@
<<POWHEG matching: process deps: TBP>>=
procedure :: write => process_deps_write
<<POWHEG matching: sub interfaces>>=
module subroutine process_deps_write (process_deps, unit)
class(process_deps_t), intent(in) :: process_deps
integer, intent(in), optional :: unit
end subroutine process_deps_write
<<POWHEG matching: procedures>>=
module subroutine process_deps_write (process_deps, unit)
class(process_deps_t), intent(in) :: process_deps
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(1X,A)") "Process dependencies:"
write (u, "(3X,A," // FMT_19 // ")") "lambda2_gen = ", &
process_deps%lambda2_gen
write (u, "(3X,A," // FMT_19 // ")") "lambda5MSB = ", &
process_deps%lambda5MSB
write (u, "(3X,A, I12)") "n_alr = ", process_deps%n_alr
write (u, "(3X,A, L12)") "lab_is_cm = ", process_deps%lab_is_cm
write (u, "(3X,A, I10)") "alpha_power = ", process_deps%alpha_power
write (u, "(3X,A, I9)") "alphas_power = ", process_deps%alphas_power
write (u, "(3X,A, I10)") "i_term_born = ", process_deps%i_term_born
do i = 1, size(process_deps%i_term_real)
write (u, "(3X,A,I2,A, I6)") "i_term_real(",i,") = ", &
process_deps%i_term_real(i)
end do
call process_deps%pdf_data%write(u)
end subroutine process_deps_write
@ %def process_deps_write
@
<<POWHEG matching: public>>=
public :: event_deps_t
<<POWHEG matching: types>>=
type :: event_deps_t
real(default) :: s_hat
real(default), dimension(2) :: x_born
real(default) :: s_had
type(phs_point_set_t) :: p_born_cms
type(phs_point_set_t) :: p_born_lab
type(phs_point_set_t) :: p_real_cms
type(phs_point_set_t) :: p_real_lab
real(default), dimension(:), allocatable :: sqme_born
contains
<<POWHEG matching: event deps: TBP>>
end type event_deps_t
@ %def event_deps_t
@
<<POWHEG matching: event deps: TBP>>=
procedure :: write => event_deps_write
<<POWHEG matching: sub interfaces>>=
module subroutine event_deps_write (event_deps, unit)
class(event_deps_t), intent(in) :: event_deps
integer, intent(in), optional :: unit
end subroutine event_deps_write
<<POWHEG matching: procedures>>=
module subroutine event_deps_write (event_deps, unit)
class(event_deps_t), intent(in) :: event_deps
integer, intent(in), optional :: unit
integer :: u, alr
u = given_output_unit (unit); if (u < 0) return
write (u, "(1X,A)") "Event dependencies:"
write (u, "(3X,A," // FMT_19 // ")") "s_hat = ", event_deps%s_hat
write (u, "(3X,A," // FMT_19 // ")") "x(+) = ", event_deps%x_born(I_PLUS)
write (u, "(3X,A," // FMT_19 // ")") "x(-) = ", event_deps%x_born(I_MINUS)
write (u, "(3X,A," // FMT_19 // ")") "s_had = ", event_deps%s_had
do alr = 1, size(event_deps%sqme_born)
write (u, "(3X,A,I3,A," // FMT_19 // ")") "sqme_born(",alr,") = ", &
event_deps%sqme_born(alr)
end do
end subroutine event_deps_write
@ %def event_deps_write
@
<<POWHEG matching: event deps: TBP>>=
procedure :: update => event_deps_update
<<POWHEG matching: sub interfaces>>=
module subroutine event_deps_update (event_deps, sqme_born, &
p_born, x_born, lt_lab_to_cms)
class(event_deps_t), intent(inout) :: event_deps
real(default), dimension(:), intent(in) :: sqme_born
type(vector4_t), dimension(:), intent(in) :: p_born
real(default), dimension(2), intent(in) :: x_born
type(lorentz_transformation_t), intent(in), optional :: lt_lab_to_cms
end subroutine event_deps_update
<<POWHEG matching: procedures>>=
module subroutine event_deps_update (event_deps, sqme_born, &
p_born, x_born, lt_lab_to_cms)
class(event_deps_t), intent(inout) :: event_deps
real(default), dimension(:), intent(in) :: sqme_born
type(vector4_t), dimension(:), intent(in) :: p_born
real(default), dimension(2), intent(in) :: x_born
type(lorentz_transformation_t), intent(in), optional :: lt_lab_to_cms
integer :: n_born
if (allocated(event_deps%sqme_born)) then
event_deps%sqme_born = sqme_born
else
allocate(event_deps%sqme_born, source=sqme_born)
end if
n_born = size (p_born)
if (debug_active (D_MATCHING)) then
if (n_born /= event_deps%p_born_lab%get_n_particles (1)) then
call msg_fatal &
("event_deps_update: number of born_momenta has changed")
end if
end if
call event_deps%p_born_lab%set_momenta (1, p_born)
call event_deps%set_cms (lt_lab_to_cms)
event_deps%x_born = x_born
event_deps%s_had = event_deps%s_hat / ( x_born(I_PLUS) * x_born(I_MINUS) )
end subroutine event_deps_update
@ %def event_deps_update
@ Sets the Born momenta in the CMS boosting them if necessary.
<<POWHEG matching: event deps: TBP>>=
procedure :: set_cms => event_deps_set_cms
<<POWHEG matching: sub interfaces>>=
module subroutine event_deps_set_cms (event_deps, lt_lab_to_cms)
class(event_deps_t), intent(inout) :: event_deps
type(lorentz_transformation_t), intent(in), optional :: lt_lab_to_cms
end subroutine event_deps_set_cms
<<POWHEG matching: procedures>>=
module subroutine event_deps_set_cms (event_deps, lt_lab_to_cms)
class(event_deps_t), intent(inout) :: event_deps
type(lorentz_transformation_t), intent(in), optional :: lt_lab_to_cms
associate (pp => event_deps%p_born_lab%phs_point(1))
event_deps%s_hat = pp%get_msq ([1,2])
if (present (lt_lab_to_cms)) then
event_deps%p_born_cms%phs_point(1) = lt_lab_to_cms * pp
else
event_deps%p_born_cms%phs_point(1) = pp
end if
end associate
end subroutine event_deps_set_cms
@ %def event_deps_set_cms
@
<<POWHEG matching: types>>=
type :: veto_counter_t
integer :: n_ubf = 0
integer :: n_xi_max = 0
integer :: n_norm = 0
integer :: n_sqme = 0
integer :: n_veto_ubf = 0
integer :: n_veto_xi_max = 0
integer :: n_veto_norm = 0
integer :: n_veto_sqme = 0
integer :: n_fail_ubf = 0
contains
<<POWHEG matching: veto counter: TBP>>
end type veto_counter_t
@ %def veto_counter_t
@
<<POWHEG matching: veto counter: TBP>>=
procedure :: record_ubf => veto_counter_record_ubf
<<POWHEG matching: sub interfaces>>=
pure module subroutine veto_counter_record_ubf (counter, vetoed)
class(veto_counter_t), intent(inout) :: counter
logical, intent(in) :: vetoed
end subroutine veto_counter_record_ubf
<<POWHEG matching: procedures>>=
pure module subroutine veto_counter_record_ubf (counter, vetoed)
class(veto_counter_t), intent(inout) :: counter
logical, intent(in) :: vetoed
counter%n_ubf = counter%n_ubf + 1
if (vetoed) counter%n_veto_ubf = counter%n_veto_ubf + 1
end subroutine veto_counter_record_ubf
@ %def veto_counter_record_ubf
@
<<POWHEG matching: veto counter: TBP>>=
procedure :: record_xi_max => veto_counter_record_xi_max
<<POWHEG matching: sub interfaces>>=
module subroutine veto_counter_record_xi_max (counter, vetoed)
class(veto_counter_t), intent(inout) :: counter
logical, intent(in) :: vetoed
end subroutine veto_counter_record_xi_max
<<POWHEG matching: procedures>>=
module subroutine veto_counter_record_xi_max (counter, vetoed)
class(veto_counter_t), intent(inout) :: counter
logical, intent(in) :: vetoed
counter%n_xi_max = counter%n_xi_max + 1
if (vetoed) counter%n_veto_xi_max = counter%n_veto_xi_max + 1
end subroutine veto_counter_record_xi_max
@ %def veto_counter_record_xi_max
@
<<POWHEG matching: veto counter: TBP>>=
procedure :: record_norm => veto_counter_record_norm
<<POWHEG matching: sub interfaces>>=
module subroutine veto_counter_record_norm (counter, vetoed)
class(veto_counter_t), intent(inout) :: counter
logical, intent(in) :: vetoed
end subroutine veto_counter_record_norm
<<POWHEG matching: procedures>>=
module subroutine veto_counter_record_norm (counter, vetoed)
class(veto_counter_t), intent(inout) :: counter
logical, intent(in) :: vetoed
counter%n_norm = counter%n_norm + 1
if (vetoed) counter%n_veto_norm = counter%n_veto_norm + 1
end subroutine veto_counter_record_norm
@ %def veto_counter_record_norm
@
<<POWHEG matching: veto counter: TBP>>=
procedure :: record_sqme => veto_counter_record_sqme
<<POWHEG matching: sub interfaces>>=
module subroutine veto_counter_record_sqme (counter, vetoed)
class(veto_counter_t), intent(inout) :: counter
logical, intent(in) :: vetoed
end subroutine veto_counter_record_sqme
<<POWHEG matching: procedures>>=
module subroutine veto_counter_record_sqme (counter, vetoed)
class(veto_counter_t), intent(inout) :: counter
logical, intent(in) :: vetoed
counter%n_sqme = counter%n_sqme + 1
if (vetoed) counter%n_veto_sqme = counter%n_veto_sqme + 1
end subroutine veto_counter_record_sqme
@ %def veto_counter_record_sqme
@
<<POWHEG matching: veto counter: TBP>>=
procedure :: record_ubf_fail => veto_counter_record_ubf_fail
<<POWHEG matching: sub interfaces>>=
module subroutine veto_counter_record_ubf_fail (counter)
class(veto_counter_t), intent(inout) :: counter
end subroutine veto_counter_record_ubf_fail
<<POWHEG matching: procedures>>=
module subroutine veto_counter_record_ubf_fail (counter)
class(veto_counter_t), intent(inout) :: counter
counter%n_fail_ubf = counter%n_fail_ubf + 1
end subroutine veto_counter_record_ubf_fail
@ %def veto_counter_record_ubf_fail
@ This routine fills the POWHEG veto log file with content showing how many
events have been vetoed in which step of the sudakov veto algorithm.
<<POWHEG matching: veto counter: TBP>>=
procedure :: write => veto_counter_write
<<POWHEG matching: sub interfaces>>=
module subroutine veto_counter_write (counter, unit)
class(veto_counter_t), intent(in) :: counter
integer, intent(in), optional :: unit
end subroutine veto_counter_write
<<POWHEG matching: procedures>>=
module subroutine veto_counter_write (counter, unit)
class(veto_counter_t), intent(in) :: counter
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(A29,I10)") "Nr. of ubf-veto calls: ", counter%n_ubf
write (u, "(A29,I10)") "Nr. of ubf-vetos: ", counter%n_veto_ubf
if (counter%n_ubf > 0) &
write (u, "(A29,F9.2,A1)") "Fraction of vetoed points: ", &
one * counter%n_veto_ubf / counter%n_ubf * 100, "%"
call write_separator (u)
write (u, "(A29,I10)") "Nr. of xi_max-veto calls: ", counter%n_xi_max
write (u, "(A29,I10)") "Nr. of xi_max-vetos: ", counter%n_veto_xi_max
if (counter%n_xi_max > 0) &
write (u, "(A29,F9.2,A1)") "Fraction of vetoed points: ", &
one * counter%n_veto_xi_max / counter%n_xi_max * 100, "%"
call write_separator (u)
write (u, "(A29,I10)") "Nr. of norm-veto calls: ", counter%n_norm
write (u, "(A29,I10)") "Nr. of norm-vetos: ", counter%n_veto_norm
if (counter%n_norm > 0) &
write (u, "(A29,F9.2,A1)") "Fraction of vetoed points: ", &
one * counter%n_veto_norm / counter%n_norm * 100, "%"
call write_separator (u)
write (u, "(A29,I10)") "Nr. of sqme-veto calls: ", counter%n_sqme
write (u, "(A29,I10)") "Nr. of sqme-vetos: ", counter%n_veto_sqme
if (counter%n_sqme > 0) &
write (u, "(A29,F9.2,A1)") "Fraction of vetoed points: ", &
one * counter%n_veto_sqme / counter%n_sqme * 100, "%"
call write_separator (u)
write (u, "(A29,I10)") "Nr. of upper-bound failures: ", &
counter%n_fail_ubf
if (counter%n_sqme > 0) &
write (u, "(A29,F9.2,A1)") "Fraction of failed points: ", &
one * counter%n_fail_ubf / counter%n_sqme * 100, "%"
end subroutine veto_counter_write
@ %def veto_counter_write
@
\subsection{Upper bounding functions and [[sudakov]]s}
\subsubsection{Abstract version}
This contains the pieces that depend on the radiation region $\alpha_r$
<<POWHEG matching: public>>=
public :: sudakov_t
<<POWHEG matching: types>>=
type, abstract, extends (solver_function_t) :: sudakov_t
type(process_deps_t), pointer :: process_deps => null()
type(event_deps_t), pointer :: event_deps => null()
type(powheg_settings_t), pointer :: powheg_settings => null()
type(phs_fks_generator_t), pointer :: phs_fks_generator => null()
type(qcd_t) :: qcd
class(rng_t), pointer :: rng => null()
real(default) :: xi2_max = zero
real(default) :: norm_max = zero
real(default) :: current_pt2_max = zero
real(default) :: sum_log_rands = zero
real(default) :: random = zero
type(veto_counter_t) :: veto_counter
integer :: i_phs = 0
contains
<<POWHEG matching: sudakov: TBP>>
end type sudakov_t
@ %def sudakov_t
@
<<POWHEG matching: sudakov: TBP>>=
procedure :: write => sudakov_write
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_write (sudakov, unit)
class(sudakov_t), intent(in) :: sudakov
integer, intent(in), optional :: unit
end subroutine sudakov_write
<<POWHEG matching: procedures>>=
module subroutine sudakov_write (sudakov, unit)
class(sudakov_t), intent(in) :: sudakov
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(3X,A," // FMT_19 // ")") "xi2_max = ", sudakov%xi2_max
write (u, "(3X,A," // FMT_19 // ")") "norm_max = ", sudakov%norm_max
write (u, "(3X,A," // FMT_19 // ")") &
"current_pt2_max = ", sudakov%current_pt2_max
write (u, "(3X,A," // FMT_19 // ")") "sum_log_rands = ", sudakov%sum_log_rands
write (u, "(3X,A," // FMT_19 // ")") "random = ", sudakov%random
end subroutine sudakov_write
@ %def sudakov_write
@ To allow for arrays of this class
<<POWHEG matching: public>>=
public :: sudakov_wrapper_t
<<POWHEG matching: types>>=
type :: sudakov_wrapper_t
class(sudakov_t), allocatable :: s
end type sudakov_wrapper_t
@ %def sudakov_wrapper_t
@
<<POWHEG matching: sudakov: TBP>>=
procedure :: init => sudakov_init
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_init (sudakov, process_deps, event_deps, &
powheg_settings, qcd, phs_fks_generator, rng)
class(sudakov_t), intent(out) :: sudakov
type(process_deps_t), target, intent(in) :: process_deps
type(event_deps_t), target, intent(in) :: event_deps
type(powheg_settings_t), target, intent(in) :: powheg_settings
type(qcd_t), intent(in) :: qcd
type(phs_fks_generator_t), target, intent(in) :: phs_fks_generator
class(rng_t), target, intent(in), optional :: rng
end subroutine sudakov_init
<<POWHEG matching: procedures>>=
module subroutine sudakov_init (sudakov, process_deps, event_deps, &
powheg_settings, qcd, phs_fks_generator, rng)
class(sudakov_t), intent(out) :: sudakov
type(process_deps_t), target, intent(in) :: process_deps
type(event_deps_t), target, intent(in) :: event_deps
type(powheg_settings_t), target, intent(in) :: powheg_settings
type(qcd_t), intent(in) :: qcd
type(phs_fks_generator_t), target, intent(in) :: phs_fks_generator
class(rng_t), target, intent(in), optional :: rng
sudakov%process_deps => process_deps
sudakov%event_deps => event_deps
sudakov%powheg_settings => powheg_settings
sudakov%qcd = qcd
sudakov%phs_fks_generator => phs_fks_generator
if (present (rng)) sudakov%rng => rng
end subroutine sudakov_init
@ %def sudakov_init
@ This has to be done after the grids are initialized.
<<POWHEG matching: sudakov: TBP>>=
procedure :: set_normalization => sudakov_set_normalization
<<POWHEG matching: sub interfaces>>=
pure module subroutine sudakov_set_normalization (sudakov, norm_max)
class(sudakov_t), intent(inout) :: sudakov
real(default), intent(in) :: norm_max
end subroutine sudakov_set_normalization
<<POWHEG matching: procedures>>=
pure module subroutine sudakov_set_normalization (sudakov, norm_max)
class(sudakov_t), intent(inout) :: sudakov
real(default), intent(in) :: norm_max
sudakov%norm_max = norm_max
end subroutine sudakov_set_normalization
@ %def sudakov_set_normalization
@
<<POWHEG matching: sudakov: TBP>>=
procedure :: update_xi2_max => sudakov_update_xi2_max
<<POWHEG matching: sub interfaces>>=
pure module subroutine sudakov_update_xi2_max (sudakov, xi2_max)
class(sudakov_t), intent(inout) :: sudakov
real(default), intent(in) :: xi2_max
end subroutine sudakov_update_xi2_max
<<POWHEG matching: procedures>>=
pure module subroutine sudakov_update_xi2_max (sudakov, xi2_max)
class(sudakov_t), intent(inout) :: sudakov
real(default), intent(in) :: xi2_max
sudakov%xi2_max = xi2_max
end subroutine sudakov_update_xi2_max
@ %def sudakov_update_xi2_max
@ [[upper_bound_func]] does \emph{not} contain the normalization $N$
which is given by the grids. In the notation of [[1002.2581]], it is
thus $\frac 1 N U(\xi,y)$
<<POWHEG matching: sudakov: TBP>>=
procedure (sudakov_upper_bound_func), deferred :: upper_bound_func
<<POWHEG matching: interfaces>>=
abstract interface
pure function sudakov_upper_bound_func (sudakov, xi, y, alpha_s) result (u)
import
real(default) :: u
class(sudakov_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y, alpha_s
end function sudakov_upper_bound_func
end interface
@ %def sudakov_upper_bound_func
@ Similar to the [[upper_bound_func]], this is
$-\frac 1 N \log\Delta(p_T^2)$ where
\begin{equation}
\Delta^{(U)} (p_T) = \exp\left[-N \int U(\xi,y)\theta(k_T - p_T) \; d\xi \, dy \, d\phi \right]
\end{equation}
<<POWHEG matching: sudakov: TBP>>=
procedure (sudakov_log_integrated_ubf), deferred :: log_integrated_ubf
<<POWHEG matching: interfaces>>=
abstract interface
pure function sudakov_log_integrated_ubf (sudakov, pt2) result (y)
import
real(default) :: y
class(sudakov_t), intent(in) :: sudakov
real(default), intent(in) :: pt2
end function sudakov_log_integrated_ubf
end interface
@ %def sudakov_log_integrated_ubf
@
<<POWHEG matching: sudakov: TBP>>=
procedure (sudakov_generate_xi_and_y_and_phi), deferred :: generate_xi_and_y_and_phi
<<POWHEG matching: interfaces>>=
abstract interface
subroutine sudakov_generate_xi_and_y_and_phi (sudakov, r)
import
class(sudakov_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_generate_xi_and_y_and_phi
end interface
@ %def sudakov_generate_xi_and_y_and_phi
@ Generating $\phi$ can be performed in a generic way for all UBF types.
<<POWHEG matching: sudakov: TBP>>=
procedure :: generate_phi => sudakov_generate_phi
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_generate_phi (sudakov, r)
class(sudakov_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_generate_phi
<<POWHEG matching: procedures>>=
module subroutine sudakov_generate_phi (sudakov, r)
class(sudakov_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
call sudakov%rng%generate (sudakov%random)
r%phi = sudakov%random * twopi
end subroutine sudakov_generate_phi
@ %def sudakov_generate_phi
@
<<POWHEG matching: sudakov: TBP>>=
procedure (sudakov_kt2), deferred :: kt2
<<POWHEG matching: interfaces>>=
abstract interface
function sudakov_kt2 (sudakov, xi, y) result (kt2)
import
real(default) :: kt2
class(sudakov_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y
end function sudakov_kt2
end interface
@ %def sudakov_kt2
@
<<POWHEG matching: sudakov: TBP>>=
procedure (sudakov_kt2_max), deferred :: kt2_max
<<POWHEG matching: interfaces>>=
abstract interface
pure function sudakov_kt2_max (sudakov) result (kt2_max)
import
real(default) :: kt2_max
class(sudakov_t), intent(in) :: sudakov
end function sudakov_kt2_max
end interface
@ %def sudakov_kt2_max
@ Veto routine for an overestimation of the UBF
performed to simplify the log integrated UBF
<<POWHEG matching: sudakov: TBP>>=
procedure (sudakov_reweight_ubf), deferred :: reweight_ubf
<<POWHEG matching: interfaces>>=
abstract interface
function sudakov_reweight_ubf (sudakov, pt2) result (accepted)
import
logical :: accepted
class(sudakov_t), intent(inout) :: sudakov
real(default), intent(in) :: pt2
end function sudakov_reweight_ubf
end interface
@ %def sudakov_reweight_ubf
@ Veto routine to correct for an overestimation of $\xi_\text{max}$
performed in the case of massive emitters.
<<POWHEG matching: sudakov: TBP>>=
procedure (sudakov_reweight_xi_max), deferred :: reweight_xi_max
<<POWHEG matching: interfaces>>=
abstract interface
function sudakov_reweight_xi_max (sudakov, xi) result (accepted)
import
logical :: accepted
class(sudakov_t), intent(in) :: sudakov
real(default), intent(in) :: xi
end function sudakov_reweight_xi_max
end interface
@ %def sudakov_reweight_xi_max
@ In the generation of $p_T^2$ via [[log_integrated_ubf]], we use the
simplified version $\alpha_s^\text{rad}$ while the grids take the
improved version.
<<POWHEG matching: sudakov: TBP>>=
procedure :: alpha_s => sudakov_alpha_s
<<POWHEG matching: sub interfaces>>=
module function sudakov_alpha_s (sudakov, kT2, use_correct, improve_nll) result (a)
real(default) :: a
class(sudakov_t), intent(in) :: sudakov
real(default), intent(in) :: kT2
logical, intent(in), optional :: use_correct, improve_nll
end function sudakov_alpha_s
<<POWHEG matching: procedures>>=
module function sudakov_alpha_s (sudakov, kT2, use_correct, improve_nll) result (a)
real(default) :: a
class(sudakov_t), intent(in) :: sudakov
real(default), intent(in) :: kT2
logical, intent(in), optional :: use_correct, improve_nll
logical :: correct, nll
correct = .false.; if (present (use_correct)) correct = use_correct
nll = .true.; if (present(improve_nll)) nll = improve_nll
if (correct) then
a = get_alpha_s (sudakov%qcd, kT2, improve_nll_opt=nll)
else
a = sudakov%alpha_s_rad (kT2)
end if
end function sudakov_alpha_s
@ %def sudakov_alpha_s
@ To generate the transverse momentum, we have to solve the equation
\begin{equation*}
\frac{\Delta^{(U)}(p_T)}{\Delta^{(U)}(p_T^{\mathrm{max}})} = r_1
\end{equation*}
iteratively for $p_T$.
In log space and with initially $\Delta^{(U)}(p_T^{\mathrm{max}}) = 1$, this is
\begin{equation*}
\log\Delta^{(U)}(p_T) = \log r_1
\end{equation*}
If no solution is found, we set $p_T = p_T^{\mathrm{min}}$ to exit the event
generation loop and generate an emissionless event.
If a solution is found but the current emission is not accepted,
we set $p_T = p_T^{\mathrm{max}}$ and thus
in the next step it is $\Delta^{(U)}(p_T^{\mathrm{max}}) = r_1$,
so that we have to solve the equation
\begin{equation*}
\log\Delta^{(U)}(p_T) = \log r_1 + \log r_2
\end{equation*}
using another random number $r_2$. We use [[sum_log_rands]] to remember
the sum of the logarithms of all previous random numbers used for this event.
<<POWHEG matching: sudakov: TBP>>=
procedure :: generate_pt2 => sudakov_generate_pt2
<<POWHEG matching: sub interfaces>>=
module function sudakov_generate_pt2 (sudakov) result (pt2)
real(default) :: pt2
class(sudakov_t), intent(inout) :: sudakov
end function sudakov_generate_pt2
<<POWHEG matching: procedures>>=
module function sudakov_generate_pt2 (sudakov) result (pt2)
real(default) :: pt2
class(sudakov_t), intent(inout) :: sudakov
logical :: success
success = .false.
if (sudakov%current_pt2_max > sudakov%powheg_settings%pt2_min) then
call sudakov%rng%generate (sudakov%random)
sudakov%sum_log_rands = sudakov%sum_log_rands + log(sudakov%random)
pt2 = solve_interval (sudakov, &
sudakov%powheg_settings%pt2_min, &
sudakov%current_pt2_max, success, &
0.001_default)
end if
if (.not. success) then
pt2 = sudakov%powheg_settings%pt2_min
end if
end function sudakov_generate_pt2
@ %def sudakov_generate_pt2
@ This could be activated [[if (debug_active (MATCHING))]].
<<POWHEG matching: sudakov: TBP>>=
procedure :: check_solution_interval => sudakov_check_solution_interval
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_check_solution_interval (sudakov)
class(sudakov_t), intent(inout) :: sudakov
end subroutine sudakov_check_solution_interval
<<POWHEG matching: procedures>>=
module subroutine sudakov_check_solution_interval (sudakov)
class(sudakov_t), intent(inout) :: sudakov
real(default) :: r
real(default), parameter :: dr = 0.05
real(default) :: pt2
logical :: success
r = 0._default
do
r = r + dr
sudakov%random = r
pt2 = solve_interval (sudakov, &
sudakov%powheg_settings%pt2_min, &
sudakov%current_pt2_max, success, &
0.001_default)
if (success) then
print *, 'r: ', r, ' zero found'
else
print *, 'r: ', r, 'no zero found'
end if
if (r >= 1._default) exit
end do
end subroutine sudakov_check_solution_interval
@ %def sudakov_check_solution_interval
@ Generates the FKS variables $(\xi, y,\phi)$ and sets the emission hardness scale.
In debug mode, we assert that the [[pt2]] saved in the [[radiation_t]]
and the massive hardness scale are equal.
This should hold as we compute [[kt2]] with the [[y]] we got from generating
[[pt2]] so that this is a full circle.
It then initiates the generation of the transverse momentum followed by
a sequence of veto steps to get the correct distribution.
<<POWHEG matching: sudakov: TBP>>=
procedure :: generate_emission => sudakov_generate_emission
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_generate_emission (sudakov, r, r_max)
class(sudakov_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
type(radiation_t), intent(in) :: r_max
end subroutine sudakov_generate_emission
<<POWHEG matching: procedures>>=
module subroutine sudakov_generate_emission (sudakov, r, r_max)
class(sudakov_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
type(radiation_t), intent(in) :: r_max
logical :: accepted
sudakov%current_pt2_max = r%pt2
if (debug_on) call msg_debug2 (D_MATCHING, "sudakov_generate_emission")
if (debug_on) call msg_debug2 (D_MATCHING, "sqrt (sudakov%current_pt2_max)", &
sqrt (sudakov%current_pt2_max))
if (debug_on) call msg_debug2 (D_MATCHING, "sudakov%sum_log_rands", sudakov%sum_log_rands)
LOOP_UNTIL_ACCEPTED: do
if (signal_is_pending ()) return
r%valid = .false.
r%pt2 = sudakov%generate_pt2 ()
if (debug_on) call msg_debug2 (D_MATCHING, "sudakov_generate_emission: after generate_pt2")
if (debug_on) call msg_debug2 (D_MATCHING, "sqrt (r%pt2)", sqrt (r%pt2))
if (debug_on) call msg_debug2 (D_MATCHING, "sudakov%sum_log_rands", sudakov%sum_log_rands)
if (r%pt2 <= sudakov%powheg_settings%pt2_min .or. r%pt2 <= r_max%pt2) then
exit
end if
accepted = sudakov%reweight_ubf (r%pt2)
call sudakov%veto_counter%record_ubf (.not. accepted)
if (.not. accepted) then
sudakov%current_pt2_max = r%pt2
cycle
end if
call sudakov%generate_xi_and_y_and_phi (r)
accepted = sudakov%reweight_xi_max (r%xi)
call sudakov%veto_counter%record_xi_max (.not. accepted)
if (.not. accepted) then
sudakov%current_pt2_max = r%pt2
cycle
end if
if (debug_active (D_MATCHING)) then
call assert_equal (OUTPUT_UNIT, r%pt2, &
sudakov%kt2 (r%xi, r%y), &
"sudakov_generate_xi_and_y_and_phi: pt2 inconsistency")
end if
r%valid = .true.
exit
end do LOOP_UNTIL_ACCEPTED
end subroutine sudakov_generate_emission
@ %def sudakov_generate_emission
@ Evaluates the Sudakov as needed for [[solve_interval]] to generate a $p_T$ value.
<<POWHEG matching: sudakov: TBP>>=
procedure :: evaluate => sudakov_evaluate
<<POWHEG matching: sub interfaces>>=
module function sudakov_evaluate (solver_f, x) result (f)
complex(default) :: f
class(sudakov_t), intent(in) :: solver_f
real(default), intent(in) :: x
end function sudakov_evaluate
<<POWHEG matching: procedures>>=
module function sudakov_evaluate (solver_f, x) result (f)
complex(default) :: f
class(sudakov_t), intent(in) :: solver_f
real(default), intent(in) :: x
f = solver_f%sum_log_rands + &
solver_f%norm_max * solver_f%log_integrated_ubf (x)
end function sudakov_evaluate
@ %def sudakov_evaluate
@
<<POWHEG matching: sudakov: TBP>>=
procedure :: associated_emitter => sudakov_associated_emitter
<<POWHEG matching: sub interfaces>>=
elemental module function sudakov_associated_emitter &
(sudakov) result (emitter)
integer :: emitter
class(sudakov_t), intent(in) :: sudakov
end function sudakov_associated_emitter
<<POWHEG matching: procedures>>=
elemental module function sudakov_associated_emitter &
(sudakov) result (emitter)
integer :: emitter
class(sudakov_t), intent(in) :: sudakov
emitter = sudakov%process_deps%phs_identifiers(sudakov%i_phs)%emitter
end function sudakov_associated_emitter
@ %def sudakov_associated_emitter
@
<<POWHEG matching: sudakov: TBP>>=
procedure :: set_i_phs => sudakov_set_i_phs
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_set_i_phs (sudakov, alr)
class(sudakov_t), intent(inout) :: sudakov
integer, intent(in) :: alr
end subroutine sudakov_set_i_phs
<<POWHEG matching: procedures>>=
module subroutine sudakov_set_i_phs (sudakov, alr)
class(sudakov_t), intent(inout) :: sudakov
integer, intent(in) :: alr
sudakov%i_phs = sudakov%process_deps%alr_to_i_phs(alr)
end subroutine sudakov_set_i_phs
@ %def sudakov_set_i_phs
@
\subsubsection{Simple FSR}
This corresponds to Appendix C of [[1002.2581]].
<<POWHEG matching: public>>=
public :: sudakov_simple_fsr_t
<<POWHEG matching: types>>=
type, extends (sudakov_t) :: sudakov_simple_fsr_t
contains
<<POWHEG matching: sudakov simple fsr: TBP>>
end type sudakov_simple_fsr_t
@ %def sudakov_simple_fsr_t
@ The simplest upper bounding function for final-state radiation is
\begin{equation}
\mathtt{upper\_bound\_func} = \frac {U(\xi,y)} N
= \frac {\alpha_s}{\xi (1-y)}
\end{equation}
<<POWHEG matching: sudakov simple fsr: TBP>>=
procedure :: upper_bound_func => sudakov_simple_fsr_upper_bound_func
<<POWHEG matching: sub interfaces>>=
pure module function sudakov_simple_fsr_upper_bound_func &
(sudakov, xi, y, alpha_s) result (u)
real(default) :: u
class(sudakov_simple_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y, alpha_s
end function sudakov_simple_fsr_upper_bound_func
<<POWHEG matching: procedures>>=
pure module function sudakov_simple_fsr_upper_bound_func &
(sudakov, xi, y, alpha_s) result (u)
real(default) :: u
class(sudakov_simple_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y, alpha_s
u = alpha_s / (xi * (1 - y))
end function sudakov_simple_fsr_upper_bound_func
@ %def sudakov_simple_fsr_upper_bound_func
@ The above upper bounding function corresponds to the transverse momentum scale
\begin{equation}
k_T^2 = \frac{s}{2} \xi^2 (1-y).
\end{equation}
<<POWHEG matching: sudakov simple fsr: TBP>>=
procedure :: kt2 => sudakov_simple_fsr_kt2
<<POWHEG matching: sub interfaces>>=
module function sudakov_simple_fsr_kt2 (sudakov, xi, y) result (kt2)
real(default) :: kt2
class(sudakov_simple_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y
end function sudakov_simple_fsr_kt2
<<POWHEG matching: procedures>>=
module function sudakov_simple_fsr_kt2 (sudakov, xi, y) result (kt2)
real(default) :: kt2
class(sudakov_simple_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y
kt2 = sudakov%phs_fks_generator%real_kinematics%kt2 &
(sudakov%i_phs, sudakov%associated_emitter (), UBF_FSR_SIMPLE, xi, y)
end function sudakov_simple_fsr_kt2
@ %def sudakov_simple_fsr_kt2
@ For massless emitters, the upper bound on the radiated energy is
\begin{equation*}
t_{\mathrm{max}} = \xi_{\mathrm{max}}^2 \hat{s}
\end{equation*}
We use this as largest possible scale for the radiation.
<<POWHEG matching: sudakov simple fsr: TBP>>=
procedure :: kt2_max => sudakov_simple_fsr_kt2_max
<<POWHEG matching: sub interfaces>>=
pure module function sudakov_simple_fsr_kt2_max (sudakov) result (kt2_max)
real(default) :: kt2_max
class(sudakov_simple_fsr_t), intent(in) :: sudakov
end function sudakov_simple_fsr_kt2_max
<<POWHEG matching: procedures>>=
pure module function sudakov_simple_fsr_kt2_max (sudakov) result (kt2_max)
real(default) :: kt2_max
class(sudakov_simple_fsr_t), intent(in) :: sudakov
real(default) :: s_hat
s_hat = sudakov%event_deps%s_hat
kt2_max = sudakov%xi2_max * s_hat
end function sudakov_simple_fsr_kt2_max
@ %def sudakov_simple_fsr_kt2_max
@ This is
\begin{equation}
- \frac{\log{\Delta^{(U)}}(p_T)}{N} =
\frac\pi{b_0} \theta\left(\xi_\text{max}^2-\frac{p_T^2}s\right)
\left[\log{\frac{\xi^2_\text{max}s}{\Lambda^2}}
\log{\frac{\log{{\xi^2_\text{max}s}/{\Lambda^2}}}
{\log{p_T^2/\Lambda^2}}} -
\log{\frac{\xi^2_\text{max}s}{p_T^2}}\right]
\end{equation}
with $p_\text{T,max}^2=\xi_\text{max}^2 s$.
<<POWHEG matching: sudakov simple fsr: TBP>>=
procedure :: log_integrated_ubf => sudakov_simple_fsr_log_integrated_ubf
<<POWHEG matching: sub interfaces>>=
pure module function sudakov_simple_fsr_log_integrated_ubf &
(sudakov, pt2) result (log_sudakov)
real(default) :: log_sudakov
class(sudakov_simple_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: pt2
end function sudakov_simple_fsr_log_integrated_ubf
<<POWHEG matching: procedures>>=
pure module function sudakov_simple_fsr_log_integrated_ubf &
(sudakov, pt2) result (log_sudakov)
real(default) :: log_sudakov
class(sudakov_simple_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: pt2
real(default) :: kt2_max, kt2_maxl, pt2l
logical :: within_boundaries
within_boundaries = pt2 <= sudakov%kt2_max () &
.and. pt2 >= sudakov%powheg_settings%pt2_min
if (within_boundaries) then
kt2_max = sudakov%kt2_max ()
kt2_maxl = kt2_max / sudakov%process_deps%lambda2_gen
pt2l = pt2 / sudakov%process_deps%lambda2_gen
log_sudakov = pi / b0rad () * (log (kt2_maxl) * &
log (log (kt2_maxl) / log (pt2l)) - &
log (kt2_max / pt2))
else
log_sudakov = 0
end if
end function sudakov_simple_fsr_log_integrated_ubf
@ %def sudakov_simple_fsr_log_integrated_ubf
@ For this upper bounding function, we just overestimated $\alpha_s$.
<<POWHEG matching: sudakov simple fsr: TBP>>=
procedure :: reweight_ubf => sudakov_simple_fsr_reweight_ubf
<<POWHEG matching: sub interfaces>>=
module function sudakov_simple_fsr_reweight_ubf &
(sudakov, pt2) result (accepted)
logical :: accepted
class(sudakov_simple_fsr_t), intent(inout) :: sudakov
real(default), intent(in) :: pt2
real(default) :: alpha_s_true, alpha_s_rad
logical :: alpha_s_equal
end function sudakov_simple_fsr_reweight_ubf
<<POWHEG matching: procedures>>=
module function sudakov_simple_fsr_reweight_ubf &
(sudakov, pt2) result (accepted)
logical :: accepted
class(sudakov_simple_fsr_t), intent(inout) :: sudakov
real(default), intent(in) :: pt2
real(default) :: alpha_s_true, alpha_s_rad
logical :: alpha_s_equal
if (debug_on) call msg_debug2 (D_MATCHING, "sudakov_simple_fsr_reweight_ubf")
alpha_s_true = sudakov%alpha_s (pt2, use_correct = .true.)
alpha_s_rad = sudakov%alpha_s (pt2, use_correct = .false.)
call sudakov%rng%generate (sudakov%random)
alpha_s_equal = nearly_equal (alpha_s_true, alpha_s_rad)
accepted = alpha_s_equal .or. sudakov%random < alpha_s_true / alpha_s_rad
if (debug2_active (D_MATCHING)) then
print *, ' sqrt(pt2) = ', sqrt(pt2)
print *, ' alpha_s_true = ', alpha_s_true
print *, ' sudakov%process_deps%lambda2_gen = ', &
sudakov%process_deps%lambda2_gen
print *, ' alpha_s_rad = ', alpha_s_rad
print *, ' sudakov%random = ', sudakov%random
print *, ' accepted = ', accepted
if (alpha_s_rad < alpha_s_true .and. .not. alpha_s_equal) then
call msg_fatal ("sudakov_simple_fsr_reweight_ubf: &
&This should never happen. &
&Have you chosen a running alpha_s?")
end if
end if
end function sudakov_simple_fsr_reweight_ubf
@ %def sudakov_simple_fsr_reweight_ubf
@
<<POWHEG matching: sudakov simple fsr: TBP>>=
procedure :: reweight_xi_max => sudakov_simple_fsr_reweight_xi_max
<<POWHEG matching: sub interfaces>>=
module function sudakov_simple_fsr_reweight_xi_max &
(sudakov, xi) result (accepted)
logical :: accepted
class(sudakov_simple_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi
end function sudakov_simple_fsr_reweight_xi_max
<<POWHEG matching: procedures>>=
module function sudakov_simple_fsr_reweight_xi_max &
(sudakov, xi) result (accepted)
logical :: accepted
class(sudakov_simple_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi
accepted = .true.
end function sudakov_simple_fsr_reweight_xi_max
@ %def sudakov_simple_fsr_reweight_xi_max
@ This depends on the choice of $p_T$ and is tested in the assertion.
<<POWHEG matching: sudakov simple fsr: TBP>>=
procedure :: generate_xi_and_y_and_phi => &
sudakov_simple_fsr_generate_xi_and_y_and_phi
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_simple_fsr_generate_xi_and_y_and_phi (sudakov, r)
class(sudakov_simple_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_simple_fsr_generate_xi_and_y_and_phi
<<POWHEG matching: procedures>>=
module subroutine sudakov_simple_fsr_generate_xi_and_y_and_phi (sudakov, r)
class(sudakov_simple_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
real(default) :: s
s = sudakov%event_deps%s_hat
call sudakov%generate_xi (r)
r%y = one - (two * r%pt2) / (s * r%xi**2)
call sudakov%generate_phi (r)
end subroutine sudakov_simple_fsr_generate_xi_and_y_and_phi
@ %def sudakov_generate_xi_and_y_and_phi
@ We generate $\xi \in [\frac{p_\text{T}}{\sqrt{s}}, \xi_\text{max}]$
with a density $1 / \xi$ i.e. uniformly in $\log(\xi)$.
<<POWHEG matching: sudakov simple fsr: TBP>>=
procedure :: generate_xi => sudakov_simple_fsr_generate_xi
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_simple_fsr_generate_xi (sudakov, r)
class(sudakov_simple_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_simple_fsr_generate_xi
<<POWHEG matching: procedures>>=
module subroutine sudakov_simple_fsr_generate_xi (sudakov, r)
class(sudakov_simple_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
real(default) :: s, xi2_max
s = sudakov%event_deps%s_hat
xi2_max = sudakov%xi2_max
call sudakov%rng%generate (sudakov%random)
r%xi = exp (((one - sudakov%random) * log (r%pt2 / s) + &
sudakov%random * log (xi2_max)) / two)
end subroutine sudakov_simple_fsr_generate_xi
@ %def sudakov_simple_fsr_generate_xi
@
\subsubsection{Dijet production at lepton colliders}
In the POWHEG method paper, $e^+e^-\to q\bar{q}$ requires a UBF different
from the simple one to account for an additional divergence for $(\xi,y) \to (1,-1)$.
<<POWHEG matching: public>>=
public :: sudakov_eeqq_fsr_t
<<POWHEG matching: types>>=
type, extends (sudakov_t) :: sudakov_eeqq_fsr_t
contains
<<POWHEG matching: sudakov eeqq fsr: TBP>>
end type sudakov_eeqq_fsr_t
@ %def sudakov_eeqq_fsr_t
@ This $k_T$ measure is the same as in the case for simple FSR up to
$\mathcal{O}(\theta^4)$ when $y=\cos(\theta)$. It differs by just a factor
of $2$ w.r.t. [[sudakov_simple_fsr_kt2]].
<<POWHEG matching: sudakov eeqq fsr: TBP>>=
procedure :: kt2 => sudakov_eeqq_fsr_kt2
<<POWHEG matching: sub interfaces>>=
module function sudakov_eeqq_fsr_kt2 (sudakov, xi, y) result (kt2)
real(default) :: kt2
class(sudakov_eeqq_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y
end function sudakov_eeqq_fsr_kt2
<<POWHEG matching: procedures>>=
module function sudakov_eeqq_fsr_kt2 (sudakov, xi, y) result (kt2)
real(default) :: kt2
class(sudakov_eeqq_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y
kt2 = sudakov%phs_fks_generator%real_kinematics%kt2 &
(sudakov%i_phs, sudakov%associated_emitter(), &
UBF_FSR_MASSLESS_RECOIL, xi, y)
end function sudakov_eeqq_fsr_kt2
@ %def sudakov_eeqq_fsr_kt2
@ For [[eeqq]], the shower starts at $k_\text{max} = \frac{q^0}{2}$.
(c.f. eq. (7.86) in [0709.2092].)
<<POWHEG matching: sudakov eeqq fsr: TBP>>=
procedure :: kt2_max => sudakov_eeqq_fsr_kt2_max
<<POWHEG matching: sub interfaces>>=
pure module function sudakov_eeqq_fsr_kt2_max (sudakov) result (kt2_max)
real(default) :: kt2_max
class(sudakov_eeqq_fsr_t), intent(in) :: sudakov
end function sudakov_eeqq_fsr_kt2_max
<<POWHEG matching: procedures>>=
pure module function sudakov_eeqq_fsr_kt2_max (sudakov) result (kt2_max)
real(default) :: kt2_max
class(sudakov_eeqq_fsr_t), intent(in) :: sudakov
kt2_max = 0.25_default * sudakov%event_deps%s_hat
end function sudakov_eeqq_fsr_kt2_max
@ %def sudakov_eeqq_fsr_kt2_max
@ This covers also the singularity at $(\xi,y)\to(1,-1)$ that occurs for
a massless recoiling system.
<<POWHEG matching: sudakov eeqq fsr: TBP>>=
procedure :: upper_bound_func => sudakov_eeqq_fsr_upper_bound_func
<<POWHEG matching: sub interfaces>>=
pure module function sudakov_eeqq_fsr_upper_bound_func &
(sudakov, xi, y, alpha_s) result (u)
real(default) :: u
class(sudakov_eeqq_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y, alpha_s
end function sudakov_eeqq_fsr_upper_bound_func
<<POWHEG matching: procedures>>=
pure module function sudakov_eeqq_fsr_upper_bound_func &
(sudakov, xi, y, alpha_s) result (u)
real(default) :: u
class(sudakov_eeqq_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y, alpha_s
u = alpha_s / (xi * (1 - y**2))
end function sudakov_eeqq_fsr_upper_bound_func
@ %def sudakov_eeqq_fsr_upper_bound_func
@ The logarithmic integrated UBF in the [[eeqq]] case as explained in
[0709.2092], eq. (7.98), is given by
\begin{align}
-\frac{1}{N} \log\left[ \Delta^{U}(p_T) \right]
&= 2 \pi \int_0^{k_\text{max}} \alpha_s(k_T)
\log \left[ \frac{4k_\text{max}^2}{k_T^2} \right] \theta(k_T - p_T)
\frac{dk_T}{k_T} \nonumber \\
&= \frac{\pi}{b_0} \left( \log \left[ \frac{4k_\text{max}^2}{k_T^2} \right]
\log \left[ \frac{\log(k_\text{max}^2/\Lambda^2)}{\log(p_T^2/\Lambda^2)} \right]
- \log \left[ \frac{k_\text{max}^2}{p_T^2} \right] \right)
\end{align}
with $k_\text{max}=\frac{q^0}{2}$.
We see that for these logarithms to be well defined, we need to set a lower bound
for the transverse momentum $p_{T,\text{min}} > \Lambda =$ [[lambda2_gen]].
% (PS 2021-05-05) Status: unvalidated
<<POWHEG matching: sudakov eeqq fsr: TBP>>=
procedure :: log_integrated_ubf => sudakov_eeqq_fsr_log_integrated_ubf
<<POWHEG matching: sub interfaces>>=
pure module function sudakov_eeqq_fsr_log_integrated_ubf &
(sudakov, pt2) result (log_sudakov)
real(default) :: log_sudakov
class(sudakov_eeqq_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: pt2
end function sudakov_eeqq_fsr_log_integrated_ubf
<<POWHEG matching: procedures>>=
pure module function sudakov_eeqq_fsr_log_integrated_ubf &
(sudakov, pt2) result (log_sudakov)
real(default) :: log_sudakov
class(sudakov_eeqq_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: pt2
real(default) :: kt2_max, Lambda2
logical :: within_boundaries
kt2_max = sudakov%kt2_max ()
within_boundaries = pt2 >= sudakov%powheg_settings%pt2_min &
.and. pt2 <= kt2_max
if (within_boundaries) then
Lambda2 = sudakov%process_deps%lambda2_gen
log_sudakov = pi / b0rad () * ( log (4 * kt2_max / Lambda2) * &
log (log (kt2_max/Lambda2) / log (pt2/Lambda2)) - log(kt2_max/pt2) )
else
log_sudakov = 0
end if
end function sudakov_eeqq_fsr_log_integrated_ubf
@ %def sudakov_eeqq_fsr_log_integrated_ubf
@ In order to arrive at the log integrated Sudakov
implemented in [[sudakov_eeqq_fsr_log_integrated_ubf]], we overestimated
\begin{equation}
\log \left[ \frac{1 + \sqrt{1 - (k_T/k_\text{max})^2}}
{1 - \sqrt{1 - (k_T/k_\text{max})^2}} \right]
\leq \log \left[ \frac{4 k_\text{max}^2}{k_T^2} \right].
\end{equation}
We correct for this in this veto step.
Additionally, we correct for overestimating $\alpha_s$.
<<POWHEG matching: sudakov eeqq fsr: TBP>>=
procedure :: reweight_ubf => sudakov_eeqq_fsr_reweight_ubf
<<POWHEG matching: sub interfaces>>=
module function sudakov_eeqq_fsr_reweight_ubf &
(sudakov, pt2) result (accepted)
logical :: accepted
class(sudakov_eeqq_fsr_t), intent(inout) :: sudakov
real(default), intent(in) :: pt2
end function sudakov_eeqq_fsr_reweight_ubf
<<POWHEG matching: procedures>>=
module function sudakov_eeqq_fsr_reweight_ubf (sudakov, pt2) result (accepted)
logical :: accepted
class(sudakov_eeqq_fsr_t), intent(inout) :: sudakov
real(default), intent(in) :: pt2
real(default) :: log_bound, k_max2
real(default) :: alpha_s_true, alpha_s_rad
alpha_s_true = sudakov%alpha_s (pt2, use_correct = .true.)
alpha_s_rad = sudakov%alpha_s (pt2, use_correct = .false.)
k_max2 = sudakov%kt2_max ()
log_bound = log((1 + sqrt(1 - (pt2/k_max2))) &
/ (1 - sqrt(1 - (pt2/k_max2))))
call sudakov%rng%generate (sudakov%random)
accepted = sudakov%random * log( 4 * k_max2 / pt2 ) * alpha_s_rad &
<= log_bound * alpha_s_true
if (debug2_active (D_MATCHING)) then
print *, ' sqrt(pt2) = ', sqrt(pt2)
print *, ' alpha_s_true = ', alpha_s_true
print *, ' sudakov%process_deps%lambda2_gen = ', &
sudakov%process_deps%lambda2_gen
print *, ' alpha_s_rad = ', alpha_s_rad
print *, ' sudakov%random = ', sudakov%random
print *, ' accepted = ', accepted
if (log( 4 * k_max2 / pt2 ) * alpha_s_rad < log_bound * alpha_s_true) then
call msg_fatal ("sudakov_eeqq_fsr_reweight_ubf: &
&This should never happen. &
&Have you chosen a running alpha_s?")
end if
end if
end function sudakov_eeqq_fsr_reweight_ubf
@ %def sudakov_eeqq_fsr_reweight_ubf
@ In the eeqq case, we did not overestimate $\xi$ with $\xi_\text{max}$.
<<POWHEG matching: sudakov eeqq fsr: TBP>>=
procedure :: reweight_xi_max => sudakov_eeqq_fsr_reweight_xi_max
<<POWHEG matching: sub interfaces>>=
module function sudakov_eeqq_fsr_reweight_xi_max &
(sudakov, xi) result (accepted)
logical :: accepted
class(sudakov_eeqq_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi
end function sudakov_eeqq_fsr_reweight_xi_max
<<POWHEG matching: procedures>>=
module function sudakov_eeqq_fsr_reweight_xi_max &
(sudakov, xi) result (accepted)
logical :: accepted
class(sudakov_eeqq_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi
accepted = .true.
end function sudakov_eeqq_fsr_reweight_xi_max
@ %def sudakov_eeqq_fsr_reweight_xi_max
@ In the eeqq case, we generate $y$ from a random number and afterwards compute
$\xi(p_T,y)$ so the sequence is reversed in comparison to the simple case.
<<POWHEG matching: sudakov eeqq fsr: TBP>>=
procedure :: generate_xi_and_y_and_phi => &
sudakov_eeqq_fsr_generate_xi_and_y_and_phi
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_eeqq_fsr_generate_xi_and_y_and_phi (sudakov, r)
class(sudakov_eeqq_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_eeqq_fsr_generate_xi_and_y_and_phi
<<POWHEG matching: procedures>>=
module subroutine sudakov_eeqq_fsr_generate_xi_and_y_and_phi (sudakov, r)
class(sudakov_eeqq_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
call sudakov%generate_y (r)
call sudakov%generate_xi (r)
call sudakov%generate_phi (r)
end subroutine sudakov_eeqq_fsr_generate_xi_and_y_and_phi
@ %def sudakov_eeqq_fsr_generate_xi_and_y_and_phi
@ To generate $y$ for the [[eeqq]] UBF, we take a random number
\begin{equation}
-\log \left[ \frac{1 + \sqrt{1 - (p_T / k_\text{max})^2 }}
{1 - \sqrt{1 - (p_T / k_\text{max})^2 }} \right]
< r_y <
\log \left[ \frac{1 + \sqrt{1 - (p_T / k_\text{max})^2 }}
{1 - \sqrt{1 - (p_T / k_\text{max})^2 }} \right]
\end{equation}
and then compute
\begin{equation}
y(r_y) = \frac{e^{r_y} - 1}{e^{r_y} + 1}
\end{equation}
<<POWHEG matching: sudakov eeqq fsr: TBP>>=
procedure :: generate_y => sudakov_eeqq_fsr_generate_y
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_eeqq_fsr_generate_y (sudakov, r)
class(sudakov_eeqq_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_eeqq_fsr_generate_y
<<POWHEG matching: procedures>>=
module subroutine sudakov_eeqq_fsr_generate_y (sudakov, r)
class(sudakov_eeqq_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
real(default) :: k_max2, log_bound, r_y
k_max2 = sudakov%kt2_max ()
call sudakov%rng%generate (sudakov%random)
log_bound = log((1 + sqrt(1 - (r%pt2/k_max2))) &
/ (1 - sqrt(1 - (r%pt2/k_max2))))
r_y = -log_bound + sudakov%random * (two * log_bound)
r%y = (exp(r_y) - 1) / (exp(r_y) + 1)
end subroutine sudakov_eeqq_fsr_generate_y
@ %def sudakov_eeqq_fsr_generate_y
@ We generate $\xi$ for the [[eeqq]] UBF according to
\begin{equation}
\xi(p_T, y) = \frac{2 p_T}{\sqrt{s} \sqrt{1-y^2}}
\end{equation}
<<POWHEG matching: sudakov eeqq fsr: TBP>>=
procedure :: generate_xi => sudakov_eeqq_fsr_generate_xi
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_eeqq_fsr_generate_xi (sudakov, r)
class(sudakov_eeqq_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_eeqq_fsr_generate_xi
<<POWHEG matching: procedures>>=
module subroutine sudakov_eeqq_fsr_generate_xi (sudakov, r)
class(sudakov_eeqq_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
real(default) :: q0
q0 = sqrt(sudakov%event_deps%s_hat)
r%xi = (2 * sqrt(r%pt2)) / (q0 * sqrt(1 - r%y**2))
end subroutine sudakov_eeqq_fsr_generate_xi
@ %def sudakov_eeqq_fsr_generate_xi
@
\subsubsection{Massive FSR}
<<POWHEG matching: public>>=
public :: sudakov_massive_fsr_t
<<POWHEG matching: types>>=
type, extends (sudakov_t) :: sudakov_massive_fsr_t
real(default) :: z, z1, z2 = 0._default
real(default) :: xi_1, xi_min, xi_m = 0._default
real(default) :: xi_max_extended = 1._default
contains
<<POWHEG matching: sudakov massive fsr: TBP>>
end type sudakov_massive_fsr_t
@ %def sudakov_massive_fsr_t
@ According to eq. A.42 [[1202.0465]], during the radiation generation,
an alternative expression for $\xi_{\mathrm{max}}$,
\begin{equation*}
\xi_{\mathrm{max}} = 1 - \frac{(m+m_{\mathrm{rec}})^2}{q^2},
\end{equation*}
is used, which corresponds to an extended Dalitz region.
Phase space points outside of the original Dalitz region
will be vetoed afterwards in [[sudakov_massive_fsr_reweight_xi_max]].
<<POWHEG matching: sudakov massive fsr: TBP>>=
procedure :: compute_xi_max_extended &
=> sudakov_massive_fsr_compute_xi_max_extended
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_massive_fsr_compute_xi_max_extended &
(sudakov)
class(sudakov_massive_fsr_t), intent(inout) :: sudakov
end subroutine sudakov_massive_fsr_compute_xi_max_extended
<<POWHEG matching: procedures>>=
module subroutine sudakov_massive_fsr_compute_xi_max_extended (sudakov)
class(sudakov_massive_fsr_t), intent(inout) :: sudakov
real(default) :: m, mrec
real(default) :: q0
type(vector4_t) :: p
q0 = sqrt(sudakov%event_deps%s_hat)
p = sudakov%event_deps%p_born_lab%get_momentum &
(1, sudakov%associated_emitter())
m = p**1
mrec = sqrt ((q0 - p%p(0))**2 - p%p(1)**2 - p%p(2)**2 - p%p(3)**2)
sudakov%xi_max_extended = one - (m + mrec)**2 / q0**2
end subroutine sudakov_massive_fsr_compute_xi_max_extended
@ %def sudakov_massive_fsr_compute_xi_max_extended
@ As described in [[1202.0465]], App. A.5., for massive emitters,
the radiation variable $\xi$ is constructed as follows. First,
\begin{equation}
\xi_{\mathrm{min}}(K_T^2)
= \frac{\sqrt{K_T^2 \left(K_T^2z_2^2 + 8\bar{p}^0q(1-z_2)\right)} - K_T^2z_2}{2q^2(1-z_2)}
\end{equation}
is computed where $K_T$ is a hardness scale for the radiation that determines the
upper limit of the integral for the Sudakov form factor and coincides with the
usual one, i.e. the transverse momentum of the radiated particle, in the massless limit.
Then $\xi_1$ is computed according to the same equation with $z_2 \leftrightarrow z_1$.
Finally, $\xi$ is generated according to
\begin{equation}
\xi = \frac{1}{q^2}\left(\exp\left[\log\left(\xi_{\rm{min}}q^2-K_T^2\right)
+ r\log\frac{\xi_m q^2 - K_T^2}{\xi_{\rm{min}}q^2-K_T^2}\right] + K_T^2\right),
\end{equation}
where $\xi_m = \rm{min}\left(\xi_{\rm{max}}, \xi_1\right)$.
<<POWHEG matching: sudakov massive fsr: TBP>>=
procedure :: generate_xi => sudakov_massive_fsr_generate_xi
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_massive_fsr_generate_xi (sudakov, r)
class(sudakov_massive_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_massive_fsr_generate_xi
<<POWHEG matching: procedures>>=
module subroutine sudakov_massive_fsr_generate_xi (sudakov, r)
class(sudakov_massive_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
real(default) :: pt2, q0, q02
real(default) :: E_em, xi_max_ext
real(default) :: xi_1, xi_min, xi_m
pt2 = r%pt2
E_em = sudakov%event_deps%p_born_lab%get_energy &
(1, sudakov%associated_emitter())
q02 = sudakov%event_deps%s_hat; q0 = sqrt(q02)
xi_max_ext = sudakov%xi_max_extended
associate (z1 => sudakov%z1, z2 => sudakov%z2)
xi_1 = (sqrt(pt2 * (pt2 * z1**2 + 8 * E_em * q0 * (one - z1))) - pt2 * z1) / &
(two * q02 * (one - z1))
xi_min = (sqrt(pt2 * (pt2 * z2**2 + 8 * E_em * q0 * (one - z2))) - pt2 * z2) / &
(two * q02 * (one - z2))
end associate
xi_m = min (xi_max_ext, xi_1)
call sudakov%rng%generate (sudakov%random)
r%xi = (exp (log(xi_min * q02 - pt2) + sudakov%random * &
log((xi_m * q02 - pt2) / (xi_min * q02 - pt2))) + pt2) / q02
end subroutine sudakov_massive_fsr_generate_xi
@ %def sudakov_massive_fsr_generate_xi
@ Generates the FKS variables in the case of a massive emitter and
additionally computes $z$ and $z_{1/2}$ as well as $\xi_\text{max}$
to be stored in the Sudakov for later use when reweighting [[xi_max]]
and retrieving the norm from the POWHEG grid.
The corresponding derivations can be found in [[1202.0465]], App. A.
<<POWHEG matching: sudakov massive fsr: TBP>>=
procedure :: generate_xi_and_y_and_phi => &
sudakov_massive_fsr_generate_xi_and_y_and_phi
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_massive_fsr_generate_xi_and_y_and_phi (sudakov, r)
class(sudakov_massive_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_massive_fsr_generate_xi_and_y_and_phi
<<POWHEG matching: procedures>>=
module subroutine sudakov_massive_fsr_generate_xi_and_y_and_phi (sudakov, r)
class(sudakov_massive_fsr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
real(default) :: q0
real(default) :: m2, mrec2, k0_rec_max
real(default) :: E_em
type(vector4_t) :: p_emitter
q0 = sqrt (sudakov%event_deps%s_hat)
p_emitter = sudakov%event_deps%p_born_lab%get_momentum &
(1, sudakov%associated_emitter())
associate (p => p_emitter%p)
mrec2 = (q0 - p(0))**2 - p(1)**2 - p(2)**2 - p(3)**2
E_em = p(0)
end associate
m2 = p_emitter**2
call compute_dalitz_bounds (q0, m2, mrec2, sudakov%z1, sudakov%z2, k0_rec_max)
call sudakov%generate_xi (r)
sudakov%z = (two * r%pt2 * E_em - r%xi**2 * q0**3) / &
(r%pt2 * r%xi * q0 - r%xi**2 * q0**3)
sudakov%xi2_max = - (q0**2 * sudakov%z**2 - two * q0 * k0_rec_max * sudakov%z + mrec2) / &
(q0**2 * sudakov%z * (one - sudakov%z))
sudakov%xi2_max = sudakov%xi2_max**2
r%y = two * (sudakov%z2 - sudakov%z) / (sudakov%z2 - sudakov%z1) - one
call sudakov%generate_phi (r)
end subroutine sudakov_massive_fsr_generate_xi_and_y_and_phi
@ %def sudakov_massive_fsr_generate_xi_and_y_and_phi
@ Computes the hardness scale as discussed in [[1202.0465]], App. A.2.
\begin{equation}
K_T^2 = \frac{\xi^2q^3 (1-z)}{2\bar{p}_{\rm{em}}^0 - z\xi q}
\label{eq:HardnessMassiveFSR}
\end{equation}
<<POWHEG matching: sudakov massive fsr: TBP>>=
procedure :: kt2 => sudakov_massive_fsr_kt2
<<POWHEG matching: sub interfaces>>=
module function sudakov_massive_fsr_kt2 (sudakov, xi, y) result (kt2)
real(default) :: kt2
class(sudakov_massive_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y
end function sudakov_massive_fsr_kt2
<<POWHEG matching: procedures>>=
module function sudakov_massive_fsr_kt2 (sudakov, xi, y) result (kt2)
real(default) :: kt2
class(sudakov_massive_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y
kt2 = sudakov%phs_fks_generator%real_kinematics%kt2 &
(sudakov%i_phs, sudakov%associated_emitter(), UBF_FSR_MASSIVE, xi, y)
end function sudakov_massive_fsr_kt2
@ %def sudakov_massive_fsr_kt2
@ For massive emitters, the upper bound on the radiated $p_T$ is
\begin{equation*}
t_{\mathrm{max}} = \frac{\xi_{\mathrm{max}}^2q^3(1-z_2)}{2 \cdot \bar{p}^0 - z_2\xi_{\mathrm{max}}q}
\end{equation*}
For this, we have to compute $z_2$ from the Dalitz bounds as [[sudakov%z2]]
has not yet been set for the current event.
<<POWHEG matching: sudakov massive fsr: TBP>>=
procedure :: kt2_max => sudakov_massive_fsr_kt2_max
<<POWHEG matching: sub interfaces>>=
pure module function sudakov_massive_fsr_kt2_max (sudakov) result (kt2_max)
real(default) :: kt2_max
class(sudakov_massive_fsr_t), intent(in) :: sudakov
end function sudakov_massive_fsr_kt2_max
<<POWHEG matching: procedures>>=
pure module function sudakov_massive_fsr_kt2_max (sudakov) result (kt2_max)
real(default) :: kt2_max
class(sudakov_massive_fsr_t), intent(in) :: sudakov
real(default) :: q0, E_em, xi_max, z1, z2, m2, mrec2, k0_rec_max
type(vector4_t) :: p_emitter
q0 = sqrt(sudakov%event_deps%s_hat)
p_emitter = sudakov%event_deps%p_born_lab%get_momentum &
(1, sudakov%associated_emitter())
associate (p => p_emitter%p)
mrec2 = (q0 - p(0))**2 - p(1)**2 - p(2)**2 - p(3)**2
E_em = p(0)
end associate
m2 = p_emitter**2
call compute_dalitz_bounds (q0, m2, mrec2, z1, z2, k0_rec_max)
xi_max = sudakov%xi_max_extended
kt2_max = (xi_max**2 * q0**3 * (one - z2)) / (two * E_em - z2 * xi_max * q0)
end function sudakov_massive_fsr_kt2_max
@ %def sudakov_massive_fsr_kt2_max
@ The upper bounding function for massive emitters according to Eq. A.56 in [1202.0465]
(disregarding a possible factor of $\alpha_s$) is
\begin{equation}
U(\xi, y) \sim \frac{\sqrt{s}}{\bar{p}_{\rm{em}}} \frac{1}{\xi(1-z)}
\label{eq:UBFMassiveFSR}
\end{equation}
<<POWHEG matching: sudakov massive fsr: TBP>>=
procedure :: upper_bound_func => sudakov_massive_fsr_upper_bound_func
<<POWHEG matching: sub interfaces>>=
pure module function sudakov_massive_fsr_upper_bound_func &
(sudakov, xi, y, alpha_s) result (u)
real(default) :: u
class(sudakov_massive_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y, alpha_s
end function sudakov_massive_fsr_upper_bound_func
<<POWHEG matching: procedures>>=
pure module function sudakov_massive_fsr_upper_bound_func &
(sudakov, xi, y, alpha_s) result (u)
real(default) :: u
class(sudakov_massive_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y, alpha_s
real(default) :: q, p_em
q = sqrt (sudakov%event_deps%s_hat)
p_em = space_part_norm &
(sudakov%event_deps%p_born_lab%get_momentum (1, &
sudakov%associated_emitter()))
u = alpha_s * q / p_em * one / (xi * (one - sudakov%z))
end function sudakov_massive_fsr_upper_bound_func
@ %def sudakov_massive_fsr_upper_bound_func
@ The integrated upper-bounding function for massive final-state emitters is given by
\begin{align*}
I(t) &= \frac{q}{\bar{p}_{\rm{em}}}\left[\log\xi\log\left[(1-z_2)\frac{q}{k_T^2}\right] +
\frac{1}{2} \log^2\xi + G(-k_T^2,q^2,\xi) - G(2\bar{p}_{\rm{em}},-q,\xi)\right]
^{\rm{min}(\xi_1(k_T^2),\xi_{\rm{max}})}_{\xi_{\rm{min}}} \\
&+ \frac{q}{\bar{p}_{\rm{em}}} \theta (\xi_{\rm{max}} - \xi_1(k_T^2))
\log\frac{\xi_{\rm{max}}}{\xi_1(k_T^2)}\log\frac{1-z_2}{1-z_1},
\end{align*}
where the function $G(a,b,\xi)$ is given by
\begin{equation}
G(a,b,\xi) = \log(a+b\xi)\log\left(1-\frac{a+b\xi}{a}\right) + Li_2\left(\frac{a+b\xi}{a}\right),
\label{GMinusMassiveFSR}
\end{equation}
for $a < 0$ and by
\begin{equation}
G(a,b,\xi) = \log\left|\frac{b\xi}{a}\right|\log a - Li_2\left(-\frac{b\xi}{a}\right) + \frac{\pi^2}{6},
\label{GPlusMassiveFSR}
\end{equation}
for $a > 0$.
<<POWHEG matching: sudakov massive fsr: TBP>>=
procedure :: log_integrated_ubf => sudakov_massive_fsr_log_integrated_ubf
<<POWHEG matching: sub interfaces>>=
pure module function sudakov_massive_fsr_log_integrated_ubf &
(sudakov, pt2) result (log_sudakov)
real(default) :: log_sudakov
class(sudakov_massive_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: pt2
end function sudakov_massive_fsr_log_integrated_ubf
<<POWHEG matching: procedures>>=
pure module function sudakov_massive_fsr_log_integrated_ubf &
(sudakov, pt2) result (log_sudakov)
real(default) :: log_sudakov
class(sudakov_massive_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: pt2
real(default) :: xi, xi_max, xi_1, xi_min
real(default) :: q0, p_em, E_em, m2, mrec2, k0_rec_max
type(vector4_t) :: p_emitter
real(default) :: log_sudakov_up, log_sudakov_down, z1, z2
logical :: within_boundaries
within_boundaries = pt2 >= sudakov%powheg_settings%pt2_min &
.and. pt2 <= sudakov%kt2_max ()
if (within_boundaries) then
q0 = sqrt (sudakov%event_deps%s_hat)
p_emitter = sudakov%event_deps%p_born_lab%get_momentum &
(1, sudakov%associated_emitter())
associate (p => p_emitter%p)
mrec2 = (q0 - p(0))**2 - p(1)**2 - p(2)**2 - p(3)**2
E_em = p(0)
end associate
m2 = p_emitter**2
call compute_dalitz_bounds (q0, m2, mrec2, z1, z2, k0_rec_max)
p_em = space_part_norm (p_emitter)
xi_max = sudakov%xi_max_extended
xi_1 = (sqrt (pt2 * (pt2 * z1**2 + 8 * E_em * q0 * (one - z1))) - pt2 * z1) / &
(two * q0**2 * (one - z1))
xi_min = (sqrt (pt2 * (pt2 * z2**2 + 8 * E_em * q0 * (one - z2))) - pt2 * z2) / &
(two * q0**2 * (one - z2))
xi = min (xi_1, xi_max)
log_sudakov_up = log(xi) * log((one - z2) * q0 / pt2) + log(xi)**2 / two + &
G_FSR(-pt2, q0**2, xi) - G_FSR(two * E_em, -q0, xi)
xi = xi_min
log_sudakov_down = log(xi) * log((one - z2) * q0 / pt2) + log(xi)**2/two + &
G_FSR(-pt2, q0**2, xi) - G_FSR(two * E_em, -q0, xi)
log_sudakov = log_sudakov_up - log_sudakov_down
if (xi_max > xi_1) &
log_sudakov = log_sudakov + log(xi_max / xi_1) * log((one - z2) / (one - z1))
log_sudakov = twopi * q0 / p_em * log_sudakov
else
log_sudakov = 0
end if
end function sudakov_massive_fsr_log_integrated_ubf
@ %def sudakov_massive_fsr_log_integrated_ubf
@ For this UBF, we just overestimated $\alpha_s$.
<<POWHEG matching: sudakov massive fsr: TBP>>=
procedure :: reweight_ubf => sudakov_massive_fsr_reweight_ubf
<<POWHEG matching: sub interfaces>>=
module function sudakov_massive_fsr_reweight_ubf &
(sudakov, pt2) result (accepted)
logical :: accepted
class(sudakov_massive_fsr_t), intent(inout) :: sudakov
real(default), intent(in) :: pt2
end function sudakov_massive_fsr_reweight_ubf
<<POWHEG matching: procedures>>=
module function sudakov_massive_fsr_reweight_ubf &
(sudakov, pt2) result (accepted)
logical :: accepted
class(sudakov_massive_fsr_t), intent(inout) :: sudakov
real(default), intent(in) :: pt2
real(default) :: alpha_s_true, alpha_s_rad
logical :: alpha_s_equal
if (debug_on) call msg_debug2 (D_MATCHING, "sudakov_massive_fsr_reweight_ubf")
alpha_s_true = sudakov%alpha_s (pt2, use_correct = .true.)
alpha_s_rad = sudakov%alpha_s (pt2, use_correct = .false.)
call sudakov%rng%generate (sudakov%random)
alpha_s_equal = nearly_equal (alpha_s_true, alpha_s_rad)
accepted = alpha_s_equal .or. sudakov%random < alpha_s_true / alpha_s_rad
if (debug2_active (D_MATCHING)) then
print *, ' sqrt(pt2) = ', sqrt(pt2)
print *, ' alpha_s_true = ', alpha_s_true
print *, ' sudakov%process_deps%lambda2_gen = ', &
sudakov%process_deps%lambda2_gen
print *, ' alpha_s_rad = ', alpha_s_rad
print *, ' sudakov%random = ', sudakov%random
print *, ' accepted = ', accepted
if (alpha_s_rad < alpha_s_true .and. .not. alpha_s_equal) then
call msg_fatal ("sudakov_massive_fsr_reweight_ubf: &
&This should never happen. &
&Have you chosen a running alpha_s?")
end if
end if
end function sudakov_massive_fsr_reweight_ubf
@ %def sudakov_massive_fsr_reweight_ubf
@
In the massive case, we generated $0 < \xi < $[[xi_max_extended]]
and thus we need to veto values of $\xi$ larger than $\xi_{\mathrm{max}}$
in this extra veto step.
<<POWHEG matching: sudakov massive fsr: TBP>>=
procedure :: reweight_xi_max => sudakov_massive_fsr_reweight_xi_max
<<POWHEG matching: sub interfaces>>=
module function sudakov_massive_fsr_reweight_xi_max &
(sudakov, xi) result (accepted)
logical :: accepted
class(sudakov_massive_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi
end function sudakov_massive_fsr_reweight_xi_max
<<POWHEG matching: procedures>>=
module function sudakov_massive_fsr_reweight_xi_max &
(sudakov, xi) result (accepted)
logical :: accepted
class(sudakov_massive_fsr_t), intent(in) :: sudakov
real(default), intent(in) :: xi
accepted = xi < sqrt (sudakov%xi2_max)
end function sudakov_massive_fsr_reweight_xi_max
@ %def sudakov_massive_fsr_reweight_xi_max
@
\subsubsection{Auxiliary functions}
Implements the function $G(a,b,\xi)$ given in eq. (\ref{GPlusMassiveFSR})
and eq. (\ref{GMinusMassiveFSR}). Cannot be evaluated for $a = 0$.
<<POWHEG matching: procedures>>=
elemental function G_FSR (a,b,xi)
real(default) :: G_FSR
real(default), intent(in) :: a, b, xi
if (a > 0) then
G_FSR = G_FSR_Plus (a,b,xi)
else if (a < 0) then
G_FSR = G_FSR_Minus (a,b,xi)
end if
end function G_FSR
elemental function G_FSR_Minus (a,b,xi)
real(default) :: G_FSR_Minus
real(default), intent(in) :: a, b, xi
G_FSR_Minus = log(a+b*xi)*log(one - (a+b*xi)/a) + Li2((a+b*xi)/a)
end function G_FSR_Minus
elemental function G_FSR_Plus (a,b,xi)
real(default) :: G_FSR_Plus
real(default), intent(in) :: a, b, xi
G_FSR_Plus = log(abs(b*xi/a))*log(a) - Li2(-b*xi/a) + pi**2/6
end function G_FSR_Plus
@ %def G_FSR, G_FSR_Minus, G_FSR_Plus
@
\subsubsection{ISR}
This is the Sudakov for ISR. This corresponds to [[1002.2581]], App. D.
The [[ubf_variant]] determines which [[log_integrated_ubf]] is used.
<<POWHEG matching: public>>=
public :: sudakov_isr_t
<<POWHEG matching: types>>=
type, extends (sudakov_t) :: sudakov_isr_t
real(default) :: xi_max_extended = 1._default
integer :: ubf_variant = 2
contains
<<POWHEG matching: sudakov isr: TBP>>
end type sudakov_isr_t
@ %def sudakov_isr_t
@ This $k_T$ measure differs by a factor of $\frac{1}{1-\xi}$ w.r.t.
[[sudakov_eeqq_fsr_kt2]] to account for
$s_\text{born} = s_\text{real} * (1 - \xi)$.
<<POWHEG matching: sudakov isr: TBP>>=
procedure :: kt2 => sudakov_isr_kt2
<<POWHEG matching: sub interfaces>>=
module function sudakov_isr_kt2 (sudakov, xi, y) result (kt2)
real(default) :: kt2
class(sudakov_isr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y
end function sudakov_isr_kt2
<<POWHEG matching: procedures>>=
module function sudakov_isr_kt2 (sudakov, xi, y) result (kt2)
real(default) :: kt2
class(sudakov_isr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y
kt2 = sudakov%phs_fks_generator%real_kinematics%kt2 &
(sudakov%i_phs, sudakov%associated_emitter(), UBF_ISR, xi, y)
end function sudakov_isr_kt2
@ %def sudakov_isr_kt2
@ The maximal transverse momentum is given by (D.4) in [1002.2581].
<<POWHEG matching: sudakov isr: TBP>>=
procedure :: kt2_max => sudakov_isr_kt2_max
<<POWHEG matching: sub interfaces>>=
pure module function sudakov_isr_kt2_max (sudakov) result (kt2_max)
real(default) :: kt2_max
class(sudakov_isr_t), intent(in) :: sudakov
end function sudakov_isr_kt2_max
<<POWHEG matching: procedures>>=
pure module function sudakov_isr_kt2_max (sudakov) result (kt2_max)
real(default) :: kt2_max
class(sudakov_isr_t), intent(in) :: sudakov
real(default) :: s_hat, xb_plus, xb_minus
s_hat = sudakov%event_deps%s_hat
xb_plus = sudakov%event_deps%x_born(I_PLUS)
xb_minus = sudakov%event_deps%x_born(I_MINUS)
kt2_max = s_hat * (1 - xb_plus**2) * (1 - xb_minus**2) &
/ (xb_plus + xb_minus)**2
end function sudakov_isr_kt2_max
@ %def sudakov_isr_kt2_max
@ This covers the soft singularity for $\xi \to 0$ and the collinear
singularities to both beam axes $y \to \pm 1$.
<<POWHEG matching: sudakov isr: TBP>>=
procedure :: upper_bound_func => sudakov_isr_upper_bound_func
<<POWHEG matching: sub interfaces>>=
pure module function sudakov_isr_upper_bound_func &
(sudakov, xi, y, alpha_s) result (u)
real(default) :: u
class(sudakov_isr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y, alpha_s
end function sudakov_isr_upper_bound_func
<<POWHEG matching: procedures>>=
pure module function sudakov_isr_upper_bound_func &
(sudakov, xi, y, alpha_s) result (u)
real(default) :: u
class(sudakov_isr_t), intent(in) :: sudakov
real(default), intent(in) :: xi, y, alpha_s
u = alpha_s / (xi * (1 - y**2))
end function sudakov_isr_upper_bound_func
@ %def sudakov_isr_upper_bound_func
@ This is eq. (D.14) and (D.18) in [1002.2581]. It is similar to the eeqq case
with the only difference beeing that the first log here includes both,
$k^2_\text{T, max}$ and $s_b$ via $q^2$.
<<POWHEG matching: sudakov isr: TBP>>=
procedure :: log_integrated_ubf => sudakov_isr_log_integrated_ubf
<<POWHEG matching: sub interfaces>>=
pure module function sudakov_isr_log_integrated_ubf &
(sudakov, pt2) result (log_sudakov)
real(default) :: log_sudakov
class(sudakov_isr_t), intent(in) :: sudakov
real(default), intent(in) :: pt2
end function sudakov_isr_log_integrated_ubf
<<POWHEG matching: procedures>>=
pure module function sudakov_isr_log_integrated_ubf &
(sudakov, pt2) result (log_sudakov)
real(default) :: log_sudakov
class(sudakov_isr_t), intent(in) :: sudakov
real(default), intent(in) :: pt2
real(default) :: kt2_max, Lambda2, s_hat, q2
logical :: within_boundaries
kt2_max = sudakov%kt2_max ()
s_hat = sudakov%event_deps%s_hat
q2 = kt2_max + s_hat
Lambda2 = sudakov%process_deps%lambda2_gen
within_boundaries = pt2 >= sudakov%powheg_settings%pt2_min &
.and. pt2 <= kt2_max
if (within_boundaries) then
if (sudakov%ubf_variant == 1) then
log_sudakov = pi / b0rad () * ( log (q2/Lambda2) * &
log (log (kt2_max/Lambda2) / log (pt2/Lambda2)) - log (kt2_max/pt2) )
elseif (sudakov%ubf_variant == 2) then
if (pt2 < s_hat) then
if (s_hat < kt2_max) then
log_sudakov = pi / b0rad () * &
( log (two * s_hat / Lambda2) &
* log (log (s_hat / Lambda2) / log (pt2 / Lambda2)) &
- log (s_hat / pt2) &
+ log (two) * log ( log (kt2_max / Lambda2) / log (s_hat / Lambda2) ))
else
log_sudakov = pi / b0rad () * &
(log (two * s_hat / Lambda2) &
* log (log (kt2_max / Lambda2) / log (pt2 / Lambda2)) &
- log (kt2_max / pt2) )
end if
else
log_sudakov = pi / b0rad () * &
(log (two) * log (log (kt2_max / Lambda2) / log (pt2 / Lambda2)))
end if
end if
else
log_sudakov = 0
end if
end function sudakov_isr_log_integrated_ubf
@ %def sudakov_isr_log_integrated_ubf
@ In order to arrive at the log integrated Sudakov
implemented in [[sudakov_isr_log_integrated_ubf]], we overestimated
\begin{equation}
\log \left[ \frac{\sqrt{x_+ - \rho} + \sqrt{x_- - \rho}}
{\sqrt{x_+ - \rho} - \sqrt{x_- - \rho}} \right]
\leq \log \left[ \frac{\sqrt{x_+} + \sqrt{x_-}}
{\sqrt{x_+} - \sqrt{x_-}} \right]
= \frac12 \log \left[ \frac{k_T^2 + s_b}{k_T^2} \right]
\leq \frac12 \log \left[ \frac{q^2}{k_T^2} \right]
\end{equation}
with
\begin{equation}
x_\pm = \left( \sqrt{1 + \frac{k_T^2}{s_b}} \pm \frac{k_T}{\sqrt{s_b}} \right)^2
\quad , \quad \rho = \frac{s_b}{S}
\quad \text{and} \quad q^2 = k^2_{T, \text{max}} + s_b.
\end{equation}
We correct for this in this veto step.
Additionally, we correct for overestimating $\alpha_s$.
<<POWHEG matching: sudakov isr: TBP>>=
procedure :: reweight_ubf => sudakov_isr_reweight_ubf
<<POWHEG matching: sub interfaces>>=
module function sudakov_isr_reweight_ubf (sudakov, pt2) result (accepted)
logical :: accepted
class(sudakov_isr_t), intent(inout) :: sudakov
real(default), intent(in) :: pt2
end function sudakov_isr_reweight_ubf
<<POWHEG matching: procedures>>=
module function sudakov_isr_reweight_ubf (sudakov, pt2) result (accepted)
logical :: accepted
class(sudakov_isr_t), intent(inout) :: sudakov
real(default), intent(in) :: pt2
real(default) :: log_bound, kT_max2, s_hat, s_had, rho, x_plus, x_minus, q2
real(default) :: alpha_s_true, alpha_s_rad
alpha_s_true = sudakov%alpha_s (pt2, use_correct = .true.)
alpha_s_rad = sudakov%alpha_s (pt2, use_correct = .false.)
s_hat = sudakov%event_deps%s_hat
s_had = sudakov%event_deps%s_had
rho = s_hat / s_had
kT_max2 = sudakov%kt2_max ()
q2 = kT_max2 + s_hat
x_plus = ( sqrt( 1 + pt2 / s_hat ) + sqrt( pt2 / s_hat ) )**2
x_minus = ( sqrt( 1 + pt2 / s_hat ) - sqrt( pt2 / s_hat ) )**2
!!! These are not the ISR x values!
call sudakov%rng%generate (sudakov%random)
log_bound = log ((sqrt( x_plus - rho ) + sqrt( x_minus - rho )) &
/ (sqrt( x_plus - rho ) - sqrt( x_minus - rho )))
if (sudakov%ubf_variant == 1) then
accepted = sudakov%random * log( q2 / pt2 ) * alpha_s_rad &
<= 2 * log_bound * alpha_s_true
elseif (sudakov%ubf_variant == 2) then
if (pt2 < s_hat) then
accepted = sudakov%random * log( two * s_hat / pt2 ) * alpha_s_rad &
<= 2 * log_bound * alpha_s_true
else
accepted = sudakov%random * log( two ) * alpha_s_rad &
<= 2 * log_bound * alpha_s_true
end if
else
accepted = .false.
call msg_error("sudakov variant not implemented")
end if
if (debug2_active (D_MATCHING)) then
print *, 'sudakov_isr_reweight_ubf:'
print *, ' sqrt(pt2) = ', sqrt(pt2)
print *, ' alpha_s_true = ', alpha_s_true
print *, ' sudakov%process_deps%lambda2_gen = ', &
sudakov%process_deps%lambda2_gen
print *, ' alpha_s_rad = ', alpha_s_rad
print *, ' sudakov%random = ', sudakov%random
print *, ' accepted = ', accepted
if (log( q2 / pt2 ) * alpha_s_rad < 2 * log_bound * alpha_s_true) then
call msg_fatal ("sudakov_isr_reweight_ubf: This should never happen. &
&Have you chosen a running alpha_s?")
end if
end if
end function sudakov_isr_reweight_ubf
@ %def sudakov_isr_reweight_ubf
@ In the ISR case, we overestimated $\xi_\text{max}$ with
$\xi_\text{max}^{\text{ext}}$.
We veto too large $\xi$ in this veto step.
<<POWHEG matching: sudakov isr: TBP>>=
procedure :: reweight_xi_max => sudakov_isr_reweight_xi_max
<<POWHEG matching: sub interfaces>>=
module function sudakov_isr_reweight_xi_max (sudakov, xi) result (accepted)
logical :: accepted
class(sudakov_isr_t), intent(in) :: sudakov
real(default), intent(in) :: xi
end function sudakov_isr_reweight_xi_max
<<POWHEG matching: procedures>>=
module function sudakov_isr_reweight_xi_max (sudakov, xi) result (accepted)
logical :: accepted
class(sudakov_isr_t), intent(in) :: sudakov
real(default), intent(in) :: xi
accepted = xi < sqrt (sudakov%xi2_max)
if (debug2_active (D_MATCHING)) then
print *, 'sudakov_isr_reweight_xi_max:'
print *, ' xi = ', xi
print *, ' xi_max = ', sqrt (sudakov%xi2_max)
print *, ' xi accepted = ', accepted
end if
end function sudakov_isr_reweight_xi_max
@ %def sudakov_isr_reweight_xi_max
@ The actual $\xi_\text{max}$ for ISR is given by eq. (\ref{eqn:xi_max_isr})
and depends on $y$ which will be known only after we generated $\xi$.
We thus use an overestimated
\begin{equation*}
\xi_{\mathrm{max}}^{\text{ext}} = 1 - \frac{s_b}{S_\text{had}}
\end{equation*}
to generate both and veto $\xi > \xi_\text{max}$ later on
in [[sudakov_isr_reweight_xi_max]].
<<POWHEG matching: sudakov isr: TBP>>=
procedure :: compute_xi_max_extended &
=> sudakov_isr_compute_xi_max_extended
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_isr_compute_xi_max_extended (sudakov)
class(sudakov_isr_t), intent(inout) :: sudakov
real(default) :: s_hat, s_had
end subroutine sudakov_isr_compute_xi_max_extended
<<POWHEG matching: procedures>>=
module subroutine sudakov_isr_compute_xi_max_extended (sudakov)
class(sudakov_isr_t), intent(inout) :: sudakov
real(default) :: s_hat, s_had
s_hat = sudakov%event_deps%s_hat
s_had = sudakov%event_deps%s_had
sudakov%xi_max_extended = one - s_hat / s_had
end subroutine sudakov_isr_compute_xi_max_extended
@ %def sudakov_isr_compute_xi_max_extended
@ In the ISR case, we generate $\xi$ from a random number and
afterwards compute $y(p_T,\xi)$ as in the simple case.
<<POWHEG matching: sudakov isr: TBP>>=
procedure :: generate_xi_and_y_and_phi => &
sudakov_isr_generate_xi_and_y_and_phi
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_isr_generate_xi_and_y_and_phi (sudakov, r)
class(sudakov_isr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_isr_generate_xi_and_y_and_phi
<<POWHEG matching: procedures>>=
module subroutine sudakov_isr_generate_xi_and_y_and_phi (sudakov, r)
class(sudakov_isr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
call sudakov%generate_xi (r)
call sudakov%generate_y (r)
call sudakov%generate_phi (r)
call sudakov%compute_xi2_max (r)
end subroutine sudakov_isr_generate_xi_and_y_and_phi
@ %def sudakov_isr_generate_xi_and_y_and_phi
@ Inverting [[real_kinematics_kt2]], we find
\begin{equation}
|y(k_T^2, \xi)| = \sqrt{1 - \frac{4 (1 - \xi)}{\xi^2}\frac{k_T^2}{s_b}}.
\end{equation}
We then determine the sign randomly as there is no preferred direction.
<<POWHEG matching: sudakov isr: TBP>>=
procedure :: generate_y => sudakov_isr_generate_y
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_isr_generate_y (sudakov, r)
class(sudakov_isr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_isr_generate_y
<<POWHEG matching: procedures>>=
module subroutine sudakov_isr_generate_y (sudakov, r)
class(sudakov_isr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
real(default) :: s_hat
s_hat = sudakov%event_deps%s_hat
r%y = sqrt (1 - (4 * (1 - r%xi) * r%pt2 / (s_hat * r%xi**2)))
call sudakov%rng%generate (sudakov%random)
if (sudakov%random > 0.5_default) then
r%y = - r%y
end if
end subroutine sudakov_isr_generate_y
@ %def sudakov_isr_generate_y
@ We want to generate $x := 1 - \xi$ for the ISR UBF with probability density
\begin{equation}
f(x) = \frac{1}{\sqrt{(x_+ - x)(x_- - x)}}.
\end{equation}
within the limits
\begin{equation}
\frac{s_b}{S} = x_{b,\oplus} x_{b,\ominus} = \rho \leq x \leq x_- = x_-
= \left( \sqrt{1 + \frac{k_T^2}{s_b}} - \frac{k_T}{\sqrt{s_b}} \right)^2.
\end{equation}
To generate $x$ according to the distribution
\begin{equation}
F(x) = \int f(x) \, dx = = 2 \sinh^{-1} \left( \sqrt{ \frac{x_- - x}{x_+ - x_-} } \right)
\end{equation}
we use
\begin{equation}
x = x_- + (x_- - x_+) \sinh^2(\frac{r_x}{2})
\end{equation}
with a random number $r_x \in \text{Unif}[F(x_-),F(\rho)]
= \text{Unif}\left[0,2 \sinh^{-1} \left( \sqrt{ \frac{x_- - \rho}{x_+ - x_-} } \right)
\right]$.\\
Alternatively, an implementation making extended use of rejection sampling is available.
<<POWHEG matching: sudakov isr: TBP>>=
procedure :: generate_xi => sudakov_isr_generate_xi
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_isr_generate_xi (sudakov, r)
class(sudakov_isr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_isr_generate_xi
<<POWHEG matching: procedures>>=
module subroutine sudakov_isr_generate_xi (sudakov, r)
class(sudakov_isr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
real(default) :: s_hat, s_had, r_x, x, x_minus, x_plus, rho
integer, parameter :: variant = 1
logical :: valid
s_hat = sudakov%event_deps%s_hat
s_had = sudakov%event_deps%s_had
rho = s_hat / s_had
x_plus = ( sqrt( 1 + r%pt2 / s_hat ) + sqrt( r%pt2 / s_hat ) )**2
x_minus = ( sqrt( 1 + r%pt2 / s_hat ) - sqrt( r%pt2 / s_hat ) )**2
if (variant == 1) then
call sudakov%rng%generate (sudakov%random)
r_x = sudakov%random
r_x = r_x * 2 * asinh (sqrt ( (x_minus - rho) / (x_plus - x_minus) ) )
x = x_minus + (x_minus - x_plus) * sinh (r_x / 2)**2
elseif (variant == 2) then
valid = .false.
do while (.not. valid)
if (signal_is_pending ()) return
call sudakov%rng%generate (sudakov%random)
r_x = sudakov%random
x = x_minus - (sqrt (x_minus - rho) * r_x)**2
call sudakov%rng%generate (sudakov%random)
r_x = sudakov%random
valid = r_x < sqrt ((x_plus - x_minus) / (x_plus - x))
end do
end if
r%xi = 1 - x
end subroutine sudakov_isr_generate_xi
@ %def sudakov_isr_generate_xi
@ Computes the actual [[xi2_max]] for ISR.
Can only be computed after y has been generated.
Needs to be called before [[sudakov_isr_reweight_xi_max]].
<<POWHEG matching: sudakov isr: TBP>>=
procedure :: compute_xi2_max => sudakov_isr_compute_xi2_max
<<POWHEG matching: sub interfaces>>=
module subroutine sudakov_isr_compute_xi2_max (sudakov, r)
class(sudakov_isr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
end subroutine sudakov_isr_compute_xi2_max
<<POWHEG matching: procedures>>=
module subroutine sudakov_isr_compute_xi2_max (sudakov, r)
class(sudakov_isr_t), intent(inout) :: sudakov
type(radiation_t), intent(inout) :: r
real(default) :: xi_max
xi_max = get_xi_max_isr (sudakov%event_deps%x_born, r%y)
sudakov%xi2_max = xi_max**2
end subroutine sudakov_isr_compute_xi2_max
@ %def sudakov_isr_compute_xi2_max
@
\subsection{Main POWHEG class}
<<POWHEG matching: public>>=
public :: powheg_matching_t
<<POWHEG matching: types>>=
type, extends(matching_t) :: powheg_matching_t
type(grid_t) :: grid
type(phs_fks_generator_t) :: phs_fks_generator
type(powheg_settings_t) :: settings
type(event_deps_t) :: event_deps
type(process_deps_t) :: process_deps
type(sudakov_wrapper_t), dimension(:), allocatable :: sudakov
integer :: n_emissions = 0
logical :: active = .true.
contains
<<POWHEG matching: powheg matching: TBP>>
end type powheg_matching_t
@ %def powheg_matching_t
@
<<POWHEG matching: powheg matching: TBP>>=
procedure :: get_method => powheg_matching_get_method
<<POWHEG matching: sub interfaces>>=
module function powheg_matching_get_method (matching) result (method)
type(string_t) :: method
class(powheg_matching_t), intent(in) :: matching
end function powheg_matching_get_method
<<POWHEG matching: procedures>>=
module function powheg_matching_get_method (matching) result (method)
type(string_t) :: method
class(powheg_matching_t), intent(in) :: matching
method = matching_method (MATCH_POWHEG)
end function powheg_matching_get_method
@ %def powheg_matching_get_method
@
<<POWHEG matching: powheg matching: TBP>>=
procedure :: before_shower => powheg_matching_before_shower
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_before_shower &
(matching, particle_set, vetoed)
class(powheg_matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
end subroutine powheg_matching_before_shower
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_before_shower &
(matching, particle_set, vetoed)
class(powheg_matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
if (debug_on) call msg_debug2 (D_MATCHING, "powheg_matching_before_shower")
if (signal_is_pending ()) return
if (.not. matching%active) return
call matching%update (particle_set)
if (matching%settings%test_sudakov) then
call matching%test_sudakov ()
stop
end if
if (.not. matching%settings%disable_sudakov) &
call matching%generate_emission (particle_set = particle_set)
vetoed = .false.
end subroutine powheg_matching_before_shower
@ %def powheg_matching_before_shower
@
<<POWHEG matching: powheg matching: TBP>>=
procedure :: first_event => powheg_matching_first_event
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_first_event (matching)
class(powheg_matching_t), intent(inout), target :: matching
end subroutine powheg_matching_first_event
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_first_event (matching)
class(powheg_matching_t), intent(inout), target :: matching
associate (instance => matching%process_instance)
matching%process_deps%lab_is_cm = instance%lab_is_cm (1)
end associate
call matching%setup_grids ()
end subroutine powheg_matching_first_event
@ %def powheg_matching_first_event
@
<<POWHEG matching: powheg matching: TBP>>=
procedure :: after_shower => powheg_matching_after_shower
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_after_shower &
(matching, particle_set, vetoed)
class(powheg_matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
end subroutine powheg_matching_after_shower
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_after_shower &
(matching, particle_set, vetoed)
class(powheg_matching_t), intent(inout) :: matching
type(particle_set_t), intent(inout) :: particle_set
logical, intent(out) :: vetoed
vetoed = .false.
end subroutine powheg_matching_after_shower
@ %def powheg_matching_after_shower
@
\subsubsection{Output}
<<POWHEG matching: powheg matching: TBP>>=
procedure :: write => powheg_write
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_write (matching, unit)
class(powheg_matching_t), intent(in) :: matching
integer, intent(in), optional :: unit
end subroutine powheg_write
<<POWHEG matching: procedures>>=
module subroutine powheg_write (matching, unit)
class(powheg_matching_t), intent(in) :: matching
integer, intent(in), optional :: unit
integer :: u, alr
u = given_output_unit (unit); if (u < 0) return
call write_separator (u, 2)
write (u, "(1X,A)") "POWHEG Emission Generator"
write (u, "(1X,A)") "Process name: " // char (matching%process_name)
if (allocated (matching%rng)) then
call matching%rng%write (u)
else
write (u, "(1X,A)") "RNG not allocated"
end if
call matching%qcd%write (u)
call matching%settings%write (u)
call matching%event_deps%write (u)
call matching%process_deps%write (u)
do alr = 1, size (matching%sudakov)
call write_separator (u)
write (u, "(1X,A,I12,A)") "sudakov (alr = ", alr, ")"
call matching%sudakov(alr)%s%write (u)
end do
call write_separator (u, 2)
end subroutine powheg_write
@ %def powheg_write
@ Finalization of the POWHEG matching.
It creates a log file showing how many events failed at which stage of the
POWHEG veto algorithm. It also issues a warning if too many POWHEG
excess events occured. If this is the case, the chosen upper-bounding
function is unsuitable for the considered process.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: final => powheg_matching_final
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_final (matching)
class(powheg_matching_t), intent(in) :: matching
end subroutine powheg_matching_final
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_final (matching)
class(powheg_matching_t), intent(in) :: matching
integer :: u, alr, n_fail_ubf_total, n_sqme_total
real :: frac_ubf_fail
type(string_t) :: filename
n_fail_ubf_total = 0
n_sqme_total = 0
u = free_unit ()
filename = matching%process_name // "_veto.log"
open (file=char(filename), unit=u, action='write')
write (u, '(A)') "Summary of POWHEG veto procedure"
do alr = 1, matching%process_deps%n_alr
write(u,'(A,I0)') 'alr: ', alr
call matching%sudakov(alr)%s%veto_counter%write (u)
call write_separator (u)
n_fail_ubf_total = n_fail_ubf_total &
+ matching%sudakov(alr)%s%veto_counter%n_fail_ubf
n_sqme_total = n_sqme_total &
+ matching%sudakov(alr)%s%veto_counter%n_sqme
end do
write (u,'(A,I0)') "Total number of events which radiate a gluon: ", &
matching%n_emissions
close (u)
if (n_sqme_total > 0) then
frac_ubf_fail = one * n_fail_ubf_total / n_sqme_total * 100
if (frac_ubf_fail > 1) then
write (msg_buffer, "(A16,I6,A2,F6.2,A24)") "There have been ", &
n_fail_ubf_total,&
" (", frac_ubf_fail, "%) POWHEG grid excesses."
call msg_warning
end if
end if
end subroutine powheg_matching_final
@ %def powheg_matching_final
@
\subsubsection{Initialization and Finalization}
Setup the POWHEG grids. As they are filled during integration using
the POWHEG hook, we can load them from file here.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: setup_grids => powheg_matching_setup_grids
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_setup_grids (matching)
class(powheg_matching_t), intent(inout), target :: matching
end subroutine powheg_matching_setup_grids
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_setup_grids (matching)
class(powheg_matching_t), intent(inout), target :: matching
call matching%prepare_for_events ()
if (matching%check_grids ()) then
call matching%load_grids ()
else
call msg_fatal ("POWHEG: POWHEG grids are invalid.")
end if
call matching%grid%compute_and_write_mean_and_max ()
call matching%import_norms_from_grid ()
end subroutine powheg_matching_setup_grids
@ %def powheg_matching_setup_grids
@ Sets up the Sudakovs and chooses the correct UBF type.
To determine the UBF type, we check for massive or initial state emitters
for each ALR. For consistency, we thus also check the eeqq case for each ALR.
Gfortran 7/8/9 bug, has to remain in the main module:
<<POWHEG matching: powheg matching: TBP>>=
procedure :: setup_sudakovs => powheg_matching_setup_sudakovs
<<POWHEG matching: main procedures>>=
subroutine powheg_matching_setup_sudakovs (powheg)
class(powheg_matching_t), intent(inout), target :: powheg
integer :: alr, ubf_type, n_in, emitter
logical :: is_fsr, is_massive, is_eeqq
allocate (powheg%sudakov (powheg%process_deps%n_alr))
do alr = 1, powheg%process_deps%n_alr
select type (pcm => powheg%process_instance%pcm)
type is (pcm_nlo_t)
associate(reg_data => pcm%region_data, &
phs => powheg%phs_fks_generator)
n_in = reg_data%get_n_in()
emitter = reg_data%get_emitter (alr)
is_fsr = emitter > n_in
if (is_fsr) then
is_massive = phs%is_massive (emitter)
else
if (emitter == 0) then
is_massive = phs%is_massive (1) .or. phs%is_massive (2)
else
is_massive = phs%is_massive (emitter)
end if
if (is_massive) call msg_bug ("setup_sudakovs: ISR " // &
"off massive emitters not implemented.")
end if
is_eeqq = n_in == 2 .and. &
reg_data%n_legs_born == 4 .and. &
.not. phs%is_massive(3) .and. &
.not. phs%is_massive(4)
! (PS 2021-05-28) This includes FSR regions of pp -> jj.
end associate
end select
if (is_fsr) then
if (is_eeqq) then
ubf_type = UBF_FSR_MASSLESS_RECOIL
else if (is_massive) then
ubf_type = UBF_FSR_MASSIVE
else
ubf_type = powheg%settings%upper_bound_func_type
end if
select case (ubf_type)
case (UBF_FSR_SIMPLE)
allocate (sudakov_simple_fsr_t :: powheg%sudakov(alr)%s)
case (UBF_FSR_MASSLESS_RECOIL)
allocate (sudakov_eeqq_fsr_t :: powheg%sudakov(alr)%s)
case (UBF_FSR_MASSIVE)
allocate (sudakov_massive_fsr_t :: powheg%sudakov(alr)%s)
case default
call msg_fatal ("powheg_setup_sudakovs: Please choose " // &
"upper bounding function!")
end select
else
allocate (sudakov_isr_t :: powheg%sudakov(alr)%s)
end if
if (allocated (powheg%rng)) then
!!! generator mode
call powheg%sudakov(alr)%s%init (powheg%process_deps, &
powheg%event_deps, powheg%settings, &
powheg%qcd, powheg%phs_fks_generator, powheg%rng)
else
!!! lookup mode
call powheg%sudakov(alr)%s%init (powheg%process_deps, &
powheg%event_deps, powheg%settings, &
powheg%qcd, powheg%phs_fks_generator)
end if
call powheg%sudakov(alr)%s%set_i_phs (alr)
end do
end subroutine powheg_matching_setup_sudakovs
@ %def powheg_matching_setup_sudakovs
@
<<POWHEG matching: powheg matching: TBP>>=
procedure :: init => powheg_matching_init
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_init (matching, var_list, process_name)
class(powheg_matching_t), intent(out) :: matching
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_name
end subroutine powheg_matching_init
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_init (matching, var_list, process_name)
class(powheg_matching_t), intent(out) :: matching
<<default matching init>>
end subroutine powheg_matching_init
@ %def powheg_matching_init
@ Updates the Born momenta and the Born matrix element stored in the event dependencies.
<<POWHEG matching: powheg matching: TBP>>=
generic :: update => update_momenta, &
update_particle_set
procedure :: update_momenta => powheg_matching_update_momenta
procedure :: update_particle_set => powheg_matching_update_particle_set
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_update_momenta (powheg, p_born)
class(powheg_matching_t), intent(inout) :: powheg
type(vector4_t), dimension(:), intent(in) :: p_born
end subroutine powheg_matching_update_momenta
module subroutine powheg_matching_update_particle_set (powheg, particle_set)
class(powheg_matching_t), intent(inout) :: powheg
type(particle_set_t), intent(in) :: particle_set
end subroutine powheg_matching_update_particle_set
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_update_momenta (powheg, p_born)
class(powheg_matching_t), intent(inout) :: powheg
type(vector4_t), dimension(:), intent(in) :: p_born
type(lorentz_transformation_t) :: lt_lab_to_cms
real(default), dimension(:), allocatable :: sqme_born
integer :: i_uborn, n_reg, alr
real(default), dimension(2) :: x_born
select type (pcm => powheg%process_instance%pcm)
type is (pcm_nlo_t)
associate (reg_data => pcm%region_data)
n_reg = reg_data%n_regions
allocate(sqme_born(n_reg))
do alr = 1, n_reg
select type (pcm_work => powheg%process_instance%pcm_work)
class is (pcm_nlo_workspace_t)
i_uborn = reg_data%regions(alr)%uborn_index
sqme_born(alr) = pcm_work%real_sub%sqme_born(i_uborn)
end select
end do
end associate
end select
x_born = powheg%phs_fks_generator%isr_kinematics%x
if (.not. powheg%process_deps%lab_is_cm) then
lt_lab_to_cms = powheg%process_instance%get_boost_to_cms (1)
call powheg%update_event_deps (sqme_born, p_born, x_born, lt_lab_to_cms)
else
call powheg%update_event_deps (sqme_born, p_born, x_born)
end if
end subroutine powheg_matching_update_momenta
module subroutine powheg_matching_update_particle_set (powheg, particle_set)
class(powheg_matching_t), intent(inout) :: powheg
type(particle_set_t), intent(in) :: particle_set
integer, dimension(:), allocatable :: indices
logical, dimension(:), allocatable :: in_out_mask
integer :: i
allocate (in_out_mask (particle_set%get_n_tot()))
do i = 1, particle_set%get_n_tot()
in_out_mask(i) = particle_set%prt(i)%get_status () == PRT_INCOMING &
.or. particle_set%prt(i)%get_status () == PRT_OUTGOING
end do
allocate (indices (size (particle_set%get_indices (in_out_mask))))
indices = particle_set%get_indices (in_out_mask)
call powheg%update_momenta (particle_set%get_momenta (indices))
end subroutine powheg_matching_update_particle_set
@ %def powheg_matching_update
@
<<POWHEG matching: powheg matching: TBP>>=
procedure :: update_event_deps => powheg_matching_update_event_deps
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_update_event_deps &
(powheg, sqme_born, p_born, x_born, lt_lab_to_cms)
class(powheg_matching_t), intent(inout) :: powheg
real(default), dimension(:), intent(in) :: sqme_born
type(vector4_t), dimension(:), intent(in) :: p_born
real(default), dimension(2), intent(in) :: x_born
type(lorentz_transformation_t), intent(in), optional :: lt_lab_to_cms
end subroutine powheg_matching_update_event_deps
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_update_event_deps &
(powheg, sqme_born, p_born, x_born, lt_lab_to_cms)
class(powheg_matching_t), intent(inout) :: powheg
real(default), dimension(:), intent(in) :: sqme_born
type(vector4_t), dimension(:), intent(in) :: p_born
real(default), dimension(2), intent(in) :: x_born
type(lorentz_transformation_t), intent(in), optional :: lt_lab_to_cms
call powheg%event_deps%update (sqme_born, p_born, x_born, lt_lab_to_cms)
end subroutine powheg_matching_update_event_deps
@ %def powheg_matching_update_event_deps
@ Boosts the real momenta to the LAB frame.
We call this only for FSR so we can take the boost from the Born term.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: boost_preal_to_lab_frame => &
powheg_matching_boost_preal_to_lab_frame
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_boost_preal_to_lab_frame (powheg, i_phs)
class(powheg_matching_t), intent(inout) :: powheg
integer, intent(in) :: i_phs
end subroutine powheg_matching_boost_preal_to_lab_frame
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_boost_preal_to_lab_frame (powheg, i_phs)
class(powheg_matching_t), intent(inout) :: powheg
type(lorentz_transformation_t) :: lt_cms_to_lab
integer, intent(in) :: i_phs
associate (event_deps => powheg%event_deps)
if (powheg%process_deps%lab_is_cm) then
event_deps%p_real_lab%phs_point(i_phs) = &
event_deps%p_real_cms%phs_point(i_phs)
else
lt_cms_to_lab = powheg%process_instance%get_boost_to_lab (1)
event_deps%p_real_lab%phs_point(i_phs) = &
lt_cms_to_lab * event_deps%p_real_cms%phs_point(i_phs)
end if
end associate
end subroutine powheg_matching_boost_preal_to_lab_frame
@ %def powheg_matching_boost_preal_to_lab_frame
@ Boosts the real momenta to the CM frame.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: boost_preal_to_cms => powheg_matching_boost_preal_to_cms
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_boost_preal_to_cms (powheg, i_phs)
class(powheg_matching_t), intent(inout) :: powheg
integer, intent(in) :: i_phs
end subroutine powheg_matching_boost_preal_to_cms
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_boost_preal_to_cms (powheg, i_phs)
class(powheg_matching_t), intent(inout) :: powheg
type(lorentz_transformation_t) :: lt
type(vector4_t), dimension(:), allocatable :: p_real
integer, intent(in) :: i_phs
real(default) :: sqrts_real
type(vector4_t) :: p0, p1
associate (event_deps => powheg%event_deps)
if (powheg%process_deps%lab_is_cm) then
event_deps%p_real_cms%phs_point(i_phs) = event_deps%p_real_lab%phs_point(i_phs)
else
p_real = event_deps%p_real_lab%phs_point(i_phs)
p0 = p_real(1) + p_real(2)
sqrts_real = (p0)**1
lt = boost (p0, sqrts_real)
p1 = inverse(lt) * p_real(1)
lt = lt * rotation_to_2nd (3, space_part (p1))
p_real = inverse (lt) * p_real
event_deps%p_real_cms%phs_point(i_phs) = p_real
end if
end associate
end subroutine powheg_matching_boost_preal_to_cms
@ %def powheg_matching_boost_preal_to_cms
@ This is the last step of the Sudakov veto algorithm removing the dependence on
the normalization factor $N(\xi_i,y_i)$ and the upper bounding function
$U(\xi,y,\alpha_s)$ from the final result.
In cases where the Born kinematic failed the cuts, $\mathcal{B}$ was
artificially set to zero, so we cannot use it in a denominator.
We assume that the generator cuts applied for parton showering are weak cuts to
avoid divergent phase space regions, thus $\mathcal{B}$ would have been large and
the reweighting would have failed.
Here, we can compute [[sqme_real]] directly with scale $p_T$
but we still need to correct [[sqme_born]].
<<POWHEG matching: powheg matching: TBP>>=
procedure :: reweight_matrix_elements => &
powheg_matching_reweight_matrix_elements
<<POWHEG matching: sub interfaces>>=
module function powheg_matching_reweight_matrix_elements &
(powheg, r) result (accepted)
logical :: accepted
class(powheg_matching_t), intent(inout) :: powheg
type(radiation_t), intent(in) :: r
end function powheg_matching_reweight_matrix_elements
<<POWHEG matching: procedures>>=
module function powheg_matching_reweight_matrix_elements &
(powheg, r) result (accepted)
logical :: accepted
class(powheg_matching_t), intent(inout) :: powheg
type(radiation_t), intent(in) :: r
integer :: emitter, n_in, i_phs, i_term_born, alphas_power, em
real(default) :: sqme_real_x_jac, sqme_born
real(default) :: norm, ubf, ubound, random, weight
real(default) :: alpha_s_kt, alpha_s_muren, alpha_s_kt_noNLL
real(default) :: muren, mufac, pt2
integer, dimension(2) :: flv_born
real(double), dimension(-6:6) :: pdf_dbl
real(double) :: x_dbl, q_dbl
type(vector4_t), dimension(:), allocatable :: p_real_cms, p_real_lab
real(default), dimension(2) :: pdf_born_mufac, pdf_born_kt
logical :: cuts_passed
if (debug_on) call msg_debug (D_MATCHING, "reweight_matrix_elements")
cuts_passed = powheg%process_instance%get_sqme(powheg%process_deps%i_term_born) > 0
if (cuts_passed) then
sqme_born = powheg%event_deps%sqme_born(r%alr)
else
sqme_born = zero
end if
if (nearly_equal(sqme_born,zero)) then
accepted = .false.
return
end if
call powheg%rng%generate (random)
i_phs = powheg%process_deps%alr_to_i_phs (r%alr)
select type (pcm => powheg%process_instance%pcm)
type is (pcm_nlo_t)
emitter = pcm%region_data%get_emitter (r%alr)
n_in = pcm%region_data%get_n_in()
if (emitter <= n_in) then
allocate(p_real_lab (pcm%region_data%get_n_legs_real()))
call powheg%phs_fks_generator%generate_isr_from_xi_and_y (&
r%xi, sqrt (powheg%sudakov(r%alr)%s%xi2_max), r%y, &
r%phi, i_phs, powheg%event_deps%p_born_lab%get_momenta(1), &
p_real_lab)
powheg%event_deps%p_real_lab%phs_point(i_phs) = p_real_lab
call powheg%boost_preal_to_cms (i_phs)
else
allocate(p_real_cms (pcm%region_data%get_n_legs_real()))
+ powheg%phs_fks_generator%m2 = invariant_mass_squared (powheg%event_deps%p_born_cms%get_momenta(1))
call powheg%phs_fks_generator%generate_fsr_from_xi_and_y (r%xi, r%y, &
r%phi, emitter, i_phs, &
powheg%event_deps%p_born_cms%get_momenta(1), &
p_real_cms)
powheg%event_deps%p_real_cms%phs_point(i_phs) = p_real_cms
call powheg%boost_preal_to_lab_frame (i_phs)
end if
if (debug_active (D_MATCHING)) then
if (emitter <= n_in) then
pt2 = (transverse_part (p_real_lab (size(p_real_lab))))**2
else
pt2 = (transverse_part (p_real_cms (size(p_real_cms))))**2
end if
call assert_equal (OUTPUT_UNIT, r%pt2, pt2, &
"reweight_matrix_elements: generated p_real does not fit to sudakovs pt2")
end if
call powheg%copy_momenta (i_phs)
norm = powheg%norm_from_xi_and_y (r)
associate (s => powheg%sudakov(r%alr)%s)
alpha_s_kt = s%alpha_s (r%pt2, use_correct=.true.)
alpha_s_kt_noNLL = s%alpha_s (r%pt2, use_correct=.true., improve_nll=.false.)
i_term_born = powheg%process_deps%i_term_born
muren = powheg%process_instance%term(i_term_born)%get_ren_scale ()
mufac = powheg%process_instance%term(i_term_born)%get_fac_scale ()
alpha_s_muren = s%alpha_s (muren**2, use_correct=.true., improve_nll=.false.)
ubf = s%upper_bound_func (r%xi, r%y, alpha_s_kt)
sqme_real_x_jac = powheg%compute_sqme_real (r%alr, sqrt(r%pt2))
select type (pcm_work => powheg%process_instance%pcm_work)
class is (pcm_nlo_workspace_t)
sqme_real_x_jac = pcm_work%powheg_kinematic_factors_real &
(sqme_real_x_jac, r%alr)
end select
!!! Correct all factors of alphas to the NLL-corrected alphas(kt).
alphas_power = powheg%process_deps%alphas_power
sqme_born = (alpha_s_kt / alpha_s_muren)**alphas_power * sqme_born
sqme_real_x_jac = (alpha_s_kt / alpha_s_kt_noNLL)**(alphas_power+1) * sqme_real_x_jac
!!! Also correct the PDFs previously computed at mufac instead of kt
select type (pcm => powheg%process_instance%pcm)
type is (pcm_nlo_t)
if (pcm%has_pdfs) then
associate (reg_data => pcm%region_data)
flv_born = reg_data%regions(r%alr)%flst_uborn%flst(1:2)
where (flv_born == 21) flv_born = 0
end associate
associate (pdf_data => powheg%process_deps%pdf_data, &
x_born => powheg%event_deps%x_born)
do em = 1, 2
x_dbl = x_born(em); q_dbl = mufac
call pdf_data%evolve(x_dbl, q_dbl, pdf_dbl)
pdf_born_mufac(em) = pdf_dbl(flv_born(em)) / x_born(em)
x_dbl = x_born(em); q_dbl = sqrt(r%pt2)
call pdf_data%evolve(x_dbl, q_dbl, pdf_dbl)
pdf_born_kt(em) = pdf_dbl(flv_born(em)) / x_born(em)
end do
sqme_born = pdf_born_kt(1) * pdf_born_kt(2) / &
(pdf_born_mufac(1) * pdf_born_mufac(2)) * sqme_born
end associate
end if
end select
if (nearly_equal(sqme_born,zero) .or. sqme_born < 0) then
accepted = .false.
return
end if
ubound = sqme_born * ubf * norm
weight = sqme_real_x_jac / ubound
if (weight > 1) call s%veto_counter%record_ubf_fail()
if (debug_active (D_MATCHING)) then
if (weight < 0) call msg_warning ("R/B < 0!")
end if
accepted = random < weight
end associate
if (debug_active (D_MATCHING)) then
print *, ' r%alr = ', r%alr
print *, ' r%xi = ', r%xi
print *, ' r%y = ', r%y
print *, ' r%phi = ', r%phi
print *, ' r%pt = ', sqrt(r%pt2)
print *, ' emitter = ', emitter
print *, ' random = ', random
print *, ' sqme_born = ', sqme_born
print *, ' sqme_real_x_jac = ', sqme_real_x_jac
print *, ' ubf = ', ubf
print *, ' norm = ', norm
print *, ' ubound = ', ubound
print *, ' matrix element accepted = ', accepted
end if
end select
end function powheg_matching_reweight_matrix_elements
@ %def powheg_matching_reweight_matrix_elements
@
\subsubsection{Generation algorithm and grid initialization}
[[compute_sqme_real]] is the projected real matrix element
$R_{\alpha_r} = S_{\alpha_r} R$ whereby the current $\alpha_r$ is
implied by the [[emitter]]. Furthermore, it is multiplied by the
real and the random number Jacobian.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: compute_sqme_real => powheg_matching_compute_sqme_real
<<POWHEG matching: sub interfaces>>=
module function powheg_matching_compute_sqme_real &
(powheg, alr, scale) result (sqme)
real(default) :: sqme
class(powheg_matching_t), intent(inout) :: powheg
integer, intent(in) :: alr
real(default), intent(in), optional :: scale
end function powheg_matching_compute_sqme_real
<<POWHEG matching: procedures>>=
module function powheg_matching_compute_sqme_real &
(powheg, alr, scale) result (sqme)
real(default) :: sqme
class(powheg_matching_t), intent(inout) :: powheg
integer, intent(in) :: alr
real(default), intent(in), optional :: scale
real(default), allocatable :: q
integer :: i_phs, i_term
logical :: is_subtraction, cuts_passed
is_subtraction = .false.
select type (pcm_work => powheg%process_instance%pcm_work)
class is (pcm_nlo_workspace_t)
i_phs = powheg%process_deps%alr_to_i_phs (alr)
i_term = powheg%process_deps%i_term_real (i_phs)
associate (instance => powheg%process_instance)
if (present(scale)) then
if (.not. allocated (q)) then
allocate (q, source = scale)
else
q = scale
end if
call instance%compute_sqme_rad &
(i_term, i_phs, is_subtraction, scale_forced=q)
else
call instance%compute_sqme_rad (i_term, i_phs, is_subtraction)
end if
cuts_passed = instance%get_sqme(i_term) > 0
if (cuts_passed) then
sqme = pcm_work%real_sub%sqme_real_arr(alr)
else
sqme = zero
end if
end associate
end select
end function powheg_matching_compute_sqme_real
@ %def powheg_matching_compute_sqme_real
@
<<POWHEG matching: powheg matching: TBP>>=
procedure :: set_scale => powheg_matching_set_scale
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_set_scale (powheg, pT2)
class(powheg_matching_t), intent(inout) :: powheg
real(default), intent(in) :: pT2
end subroutine powheg_matching_set_scale
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_set_scale (powheg, pT2)
class(powheg_matching_t), intent(inout) :: powheg
real(default), intent(in) :: pT2
call powheg%process_instance%set_fac_scale (sqrt(pT2))
end subroutine powheg_matching_set_scale
@ %def powheg_matching_set_scale
@
<<POWHEG matching: powheg matching: TBP>>=
procedure :: update_sudakovs => powheg_matching_update_sudakovs
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_update_sudakovs (powheg, alr, i_phs, y)
class(powheg_matching_t), intent(inout) :: powheg
integer, intent(in) :: alr, i_phs
real(default), intent(in) :: y
end subroutine powheg_matching_update_sudakovs
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_update_sudakovs (powheg, alr, i_phs, y)
class(powheg_matching_t), intent(inout) :: powheg
integer, intent(in) :: alr, i_phs
real(default), intent(in) :: y
real(default) :: q0, m2, mrec2, k0_rec_max
type(vector4_t) :: p_emitter
select type (s => powheg%sudakov(alr)%s)
type is (sudakov_massive_fsr_t)
q0 = sqrt (s%event_deps%s_hat)
p_emitter = s%event_deps%p_born_lab%get_momentum (1, &
s%associated_emitter ())
associate (p => p_emitter%p)
mrec2 = (q0 - p(0))**2 - p(1)**2 - p(2)**2 - p(3)**2
end associate
m2 = p_emitter**2
call compute_dalitz_bounds (q0, m2, mrec2, s%z1, s%z2, k0_rec_max)
s%z = s%z2 - (s%z2 - s%z1) * (one + y) / two
end select
end subroutine powheg_matching_update_sudakovs
@ %def powheg_matching_update_sudakovs
@
<<POWHEG matching: powheg matching: TBP>>=
procedure :: import_norms_from_grid => powheg_matching_import_norms_from_grid
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_import_norms_from_grid (powheg)
class(powheg_matching_t), intent(inout) :: powheg
end subroutine powheg_matching_import_norms_from_grid
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_import_norms_from_grid (powheg)
class(powheg_matching_t), intent(inout) :: powheg
integer :: alr
real(default) :: norm_max
do alr = 1, powheg%process_deps%n_alr
norm_max = powheg%grid%get_maximum_in_3d (alr)
call powheg%sudakov(alr)%s%set_normalization (norm_max)
end do
end subroutine powheg_matching_import_norms_from_grid
@ %def powheg_matching_import_norms_from_grid
@ We save the POWHEG grid to a file to be used for the event generation.
If it has no non-zero entries, we assume that the integration was skipped
because there were existing VAMP(2) and POWHEG grid files.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: save_grids => powheg_matching_save_grids
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_save_grids (powheg)
class(powheg_matching_t), intent(inout) :: powheg
end subroutine powheg_matching_save_grids
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_save_grids (powheg)
class(powheg_matching_t), intent(inout) :: powheg
type(string_t) :: filename, n_points
filename = powheg%process_name // ".pg"
if (powheg%grid%has_non_zero_entries()) then
call powheg%grid%save_to_file (char (filename))
else
call msg_warning("POWHEG grid not saved to file. An existing " // &
& char(filename) // " will be used for the events.")
end if
end subroutine powheg_matching_save_grids
@ %def powheg_matching_save_grids
@
<<POWHEG matching: powheg matching: TBP>>=
procedure :: load_grids => powheg_matching_load_grids
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_load_grids (powheg)
class(powheg_matching_t), intent(inout) :: powheg
end subroutine powheg_matching_load_grids
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_load_grids (powheg)
class(powheg_matching_t), intent(inout) :: powheg
type(string_t) :: filename, n_points
filename = powheg%process_name // ".pg"
call powheg%grid%load_from_file (char (filename))
if (powheg%grid%has_non_zero_entries()) then
write (msg_buffer, "(A,A,A)") "POWHEG: using grids from file '", &
char (filename), "'"
else
call msg_fatal("POWHEG grid in " // char(filename) // &
& " is zero and cannot be used for event generation.")
end if
call msg_message ()
end subroutine powheg_matching_load_grids
@ %def powheg_matching_load_grids
@
<<POWHEG matching: powheg matching: TBP>>=
procedure :: check_grids => powheg_matching_check_grids
<<POWHEG matching: sub interfaces>>=
module function powheg_matching_check_grids (powheg) result (ok)
logical :: ok
class(powheg_matching_t), intent(in) :: powheg
end function powheg_matching_check_grids
<<POWHEG matching: procedures>>=
module function powheg_matching_check_grids (powheg) result (ok)
logical :: ok
class(powheg_matching_t), intent(in) :: powheg
type(string_t) :: filename, n_points
filename = powheg%process_name // ".pg"
ok = os_file_exist (filename) .and. &
verify_points_for_grid (char (filename), &
[powheg%settings%size_grid_xi, &
powheg%settings%size_grid_y, &
powheg%process_deps%n_alr])
end function powheg_matching_check_grids
@ %def powheg_matching_check_grids
@ This routine implements the Sudakov veto algorithm as explained in
[[[1002.2581]]], Sec. 7.1 and Bijans thesis, Sec. 3.3 and B.2.
Here, we veto in order to correct for
\begin{enumerate}
\item an overestimation of parts of the upper bounding function
for complicated UBFs in [[reweight_ubf]] as well as the usage of
$\alpha_s^\text{rad}$ instead of $\alpha_s^\text{true}$.
\item the usage of [[xi_max_extended]] instead of [[xi_max]] in [[reweight_xi_max]]
which is only non-trivial for massive FSR and ISR.
\item using the maximum of the entire POWHEG normalization grid $N_\text{max}$
when generating $p_T$ instead of the correct bin value $N(\xi_i,y_i)$ in [[reweight_norm]].
\item the normalization grid and the upper bounding function in the first place
in [[reweight_matrix_elements]] to retrieve the correct fraction
$\frac{\mathcal{R}(\xi,y) \mathcal{J}(\xi,y)}{\mathcal{B}}$.
\end{enumerate}
By looping over all ALRs and in the end choosing the ALR with the largest [[pt2]],
we are effectively implementing the highest bid procedure.
To save some time generating equivalent phase spaces again and again,
we could instead loop over all radiation regions [[i_phs]],
take the sum of all real matrix elements in the Sudakov and in the end
pick the ALR with probability proportional to the corresponding
$\mathcal{R}_{\alpha_r}$. We might implement this optimization in the future.
We need to compute [[xi2_max]] before [[kt2_max]] here.
In the simple case, it is given by $\xi_\text{max} = \frac{s-M_\text{rec}^2}{s}$
but we can also take the $\xi_\text{max}$ from the phase space computed before;
they coincide. This is possible already at this point because in the simple case,
$\xi_\text{max}$ only depends on the Born momentum of the emitter and not on the
real kinematics.
In the eeqq case, $M_\text{rec} = 0$, so $\xi_\text{max} = 1$ and in the massive
case as well as in the ISR case, we compute an extended $\xi_\text{max}^\text{ext}$
because the actual $\xi_\text{max}$ depends on the real kinematics.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: generate_emission => powheg_matching_generate_emission
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_generate_emission &
(powheg, particle_set, pt2_generated)
class(powheg_matching_t), intent(inout) :: powheg
type(particle_set_t), intent(inout), optional :: particle_set
real(default), intent(out), optional :: pt2_generated
end subroutine powheg_matching_generate_emission
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_generate_emission &
(powheg, particle_set, pt2_generated)
class(powheg_matching_t), intent(inout) :: powheg
type(particle_set_t), intent(inout), optional :: particle_set
real(default), intent(out), optional :: pt2_generated
type(radiation_t) :: r, r_max
real(default) :: xi2_max
integer :: alr
logical :: accepted
logical, dimension(:), allocatable :: prt_status_mask
type(vector4_t), dimension(:), allocatable :: p_real_max
if (signal_is_pending ()) return
if (debug_on) call msg_debug (D_MATCHING, "powheg_matching_generate_emission")
allocate(prt_status_mask(particle_set%get_n_tot()))
prt_status_mask = .false.
where (particle_set%prt%get_status () == PRT_INCOMING &
.or. particle_set%prt%get_status () == PRT_OUTGOING) &
prt_status_mask = .true.
r_max%pt2 = zero
r_max%alr = 0
select type (pcm => powheg%process_instance%pcm)
type is (pcm_nlo_t)
allocate (p_real_max (pcm%region_data%n_legs_real))
end select
select type (pcm_work => powheg%process_instance%pcm_work)
class is (pcm_nlo_workspace_t)
do alr = 1, powheg%process_deps%n_alr
if (signal_is_pending ()) return
if (present (particle_set)) then
select type (pcm => powheg%process_instance%pcm)
type is (pcm_nlo_t)
if (any (pack(particle_set%prt%get_pdg (), prt_status_mask) /= &
pcm%region_data%regions(alr)%flst_uborn%flst)) then
cycle
end if
end select
end if
associate (sudakov => powheg%sudakov(alr)%s)
select type (sudakov)
type is (sudakov_simple_fsr_t)
xi2_max = pcm_work%get_xi_max (alr)**2
call sudakov%update_xi2_max (xi2_max)
if (debug2_active (D_MATCHING)) then
call check_xi2_max (sudakov)
end if
type is (sudakov_eeqq_fsr_t)
call sudakov%update_xi2_max (one)
type is (sudakov_massive_fsr_t)
call sudakov%compute_xi_max_extended ()
type is (sudakov_isr_t)
call sudakov%compute_xi_max_extended ()
class default
call msg_fatal ("powheg_matching_generate_emission: unknown Sudakov!")
end select
r%alr = alr
r%pt2 = sudakov%kt2_max ()
sudakov%sum_log_rands = 0
if (debug_on) call msg_debug (D_MATCHING, "Starting evolution at r%pt2", r%pt2)
PT_EVOLUTION: do
if (signal_is_pending ()) return
call sudakov%generate_emission (r, r_max)
if (signal_is_pending ()) return
if (r%valid) then
accepted = powheg%reweight_norm (r)
call sudakov%veto_counter%record_norm (.not. accepted)
if (.not. accepted) cycle PT_EVOLUTION
accepted = powheg%reweight_matrix_elements (r)
call sudakov%veto_counter%record_sqme (.not. accepted)
if (.not. accepted) cycle PT_EVOLUTION
end if
exit
end do PT_EVOLUTION
if (r%pt2 > r_max%pt2 .and. r%valid) then
r_max = r
p_real_max = powheg%event_deps%p_real_lab%get_momenta (sudakov%i_phs)
end if
end associate
end do
if (r_max%pt2 > powheg%settings%pt2_min) then
powheg%n_emissions = powheg%n_emissions + 1
call update_event_data (powheg, r_max%alr, r_max%pt2)
if (present (particle_set)) then
call powheg%build_particle_set (particle_set, &
p_real_max, r_max%alr, r_max%y)
end if
if (present (pt2_generated)) pt2_generated = r_max%pt2
else
call update_event_data (powheg, 1, powheg%settings%pt2_min)
if (present (pt2_generated)) pt2_generated = powheg%settings%pt2_min
end if
end select
contains
subroutine check_xi2_max (sudakov)
class(sudakov_t), intent(in) :: sudakov
real(default) :: s_hat, mrec2, xi2_max
type(vector4_t) :: p_emitter
s_hat = sudakov%event_deps%s_hat
p_emitter = sudakov%event_deps%p_born_lab%get_momentum &
(1, sudakov%associated_emitter())
associate (p => p_emitter%p)
mrec2 = (sqrt(s_hat) - p(0))**2 - p(1)**2 - p(2)**2 - p(3)**2
end associate
xi2_max = (s_hat - mrec2) / s_hat
xi2_max = xi2_max**2
call assert_equal (OUTPUT_UNIT, sudakov%xi2_max, xi2_max, &
"powheg_matching_generate_emission: xi_max inconsistent")
end subroutine check_xi2_max
!!! Force the scale pT and the value of alpha_s(p_T) into the event output.
subroutine update_event_data (powheg, alr, pt2)
class(powheg_matching_t), intent(inout) :: powheg
integer, intent(in) :: alr
real(default), intent(in) :: pt2
real(default) :: alpha_s
alpha_s = powheg%sudakov(alr)%s%alpha_s (pt2, use_correct = .true.)
select type (core_state => powheg%process_instance%term(1)%core_state)
class is (prc_external_state_t)
core_state%alpha_qcd = alpha_s
class is (omega_state_t)
core_state%alpha_qcd = alpha_s
end select
call powheg%set_scale (pt2)
end subroutine update_event_data
end subroutine powheg_matching_generate_emission
@ %def generate_emission
@
<<POWHEG matching: powheg matching: TBP>>=
procedure :: build_particle_set => powheg_matching_build_particle_set
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_build_particle_set &
(powheg, particle_set, p_real, alr, y)
class(powheg_matching_t), intent(inout) :: powheg
type(particle_set_t), intent(inout) :: particle_set
type(vector4_t), dimension(:), intent(in) :: p_real
integer, intent(in) :: alr
real(default), intent(in) :: y
end subroutine powheg_matching_build_particle_set
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_build_particle_set &
(powheg, particle_set, p_real, alr, y)
class(powheg_matching_t), intent(inout) :: powheg
type(particle_set_t), intent(inout) :: particle_set
type(vector4_t), dimension(:), intent(in) :: p_real
integer, intent(in) :: alr
real(default), intent(in) :: y
integer, dimension(:), allocatable :: i_flvs_real, flv_radiated
real(default) :: r_col
integer :: emitter, i_flv_real
select type (pcm => powheg%process_instance%pcm)
type is (pcm_nlo_t)
i_flvs_real = pcm%region_data%get_flavor_indices (.false.)
i_flv_real = i_flvs_real (alr)
allocate (flv_radiated (size (pcm%region_data%get_flv_states_real (i_flv_real))))
flv_radiated = pcm%region_data%get_flv_states_real (i_flv_real)
emitter = pcm%region_data%get_emitter(alr)
if (emitter == 0) then
if (y > 0) then
emitter = 1
else
emitter = 2
end if
end if
end select
call powheg%rng%generate (r_col)
call particle_set%build_radiation (p_real, emitter, flv_radiated, &
powheg%process_instance%process%get_model_ptr (), r_col)
end subroutine powheg_matching_build_particle_set
@ %def powheg_matching_build_particle_set
@ When generating the transverse momentum in [[sudakov_generate_pt2]],
we used $N^\mathrm{max}$ as normalization. In this veto step, we correct
for this by keeping events with probability
\begin{equation*}
\frac{N(\xi_i,y_i)}{N^\mathrm{max}}.
\end{equation*}
<<POWHEG matching: powheg matching: TBP>>=
procedure :: reweight_norm => powheg_matching_reweight_norm
<<POWHEG matching: sub interfaces>>=
module function powheg_matching_reweight_norm (powheg, r) result (accepted)
logical :: accepted
class(powheg_matching_t), intent(inout) :: powheg
type(radiation_t), intent(in) :: r
end function powheg_matching_reweight_norm
<<POWHEG matching: procedures>>=
module function powheg_matching_reweight_norm (powheg, r) result (accepted)
logical :: accepted
class(powheg_matching_t), intent(inout) :: powheg
type(radiation_t), intent(in) :: r
real(default) :: random, norm_max, norm_true
if (debug_on) call msg_debug2 (D_MATCHING, "reweight_norm")
call powheg%rng%generate (random)
norm_true = powheg%norm_from_xi_and_y (r)
norm_max = powheg%sudakov(r%alr)%s%norm_max
accepted = random < norm_true / norm_max
if (debug2_active (D_MATCHING)) then
print *, ' r%alr = ', r%alr
print *, ' random = ', random
print *, ' norm_true = ', norm_true
print *, ' norm_max = ', norm_max
print *, ' norm accepted = ', accepted
end if
if (debug_active (D_MATCHING)) then
if (.not. (zero < r%xi .and. &
r%xi < sqrt(powheg%sudakov(r%alr)%s%xi2_max))) then
call msg_bug ("powheg_matching_reweight_norm: xi is out of bounds")
end if
if (norm_true > norm_max) then
call msg_bug ("powheg_matching_reweight_norm: norm shouldnt be larger than norm_max")
end if
end if
end function powheg_matching_reweight_norm
@ %def powheg_matching_reweight_norm
@ Retrieves the value of the norm for given $\xi$ and $y$ from the pre-computed POWHEG grid.
To find the correct bin we need to map $(\xi,y)$ in some way to $[0,1]^2$.
This mapping is to the most extend arbitrary. We choose
$y \mapsto |y|$ and
$\xi \mapsto \log(1-\xi) / \log(1-\xi_{max})$.
It may be possible to improve these mappings to tune the performance for processes
with expensive matrix elements.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: norm_from_xi_and_y => powheg_matching_norm_from_xi_and_y
<<POWHEG matching: sub interfaces>>=
module function powheg_matching_norm_from_xi_and_y &
(powheg, r) result (norm_true)
real(default) :: norm_true
class(powheg_matching_t), intent(inout) :: powheg
type(radiation_t), intent(in) :: r
end function powheg_matching_norm_from_xi_and_y
<<POWHEG matching: procedures>>=
module function powheg_matching_norm_from_xi_and_y &
(powheg, r) result (norm_true)
real(default) :: norm_true
class(powheg_matching_t), intent(inout) :: powheg
type(radiation_t), intent(in) :: r
real(default) :: f_alr, xi_max
real(default), dimension(2) :: rands
f_alr = (one * r%alr) / powheg%process_deps%n_alr - tiny_07
rands(I_Y) = abs(r%y)
xi_max = min(sqrt (powheg%sudakov(r%alr)%s%xi2_max), 1 - tiny_07)
if (r%xi > xi_max) then
rands(I_XI) = 1
else
rands(I_XI) = log(1 - r%xi) / log(1 - xi_max)
end if
norm_true = powheg%grid%get_value ([rands, f_alr])
end function powheg_matching_norm_from_xi_and_y
@ %def powheg_matching_norm_from_xi_and_y
@
\subsection{$\alpha_s$ and its reweighting}
The main point to ensure here is that the simple fixed-flavor-1-loop
expression $\alpha_s^\text{rad}$ is larger than the more accurate
$\alpha_s$ such that we can use a reweighting veto and use
$\alpha_s^\text{rad}$ for the generation of the emission. This can be
done by setting
\begin{equation}
\alpha_s^\text{rad}(\mu_0) = \alpha_s (\mu_0)
\end{equation}
whereby $\mu_0^2$ is the [[scale_to_relate2]] that is taken to be
$(2 \Lambda^{(5)}_{\overline{MS}})^2$.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: prepare_for_events => powheg_matching_prepare_for_events
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_prepare_for_events (matching)
class(powheg_matching_t), intent(inout), target :: matching
end subroutine powheg_matching_prepare_for_events
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_prepare_for_events (matching)
class(powheg_matching_t), intent(inout), target :: matching
if (debug_on) call msg_debug &
(D_MATCHING, "powheg_matching_prepare_for_events")
call matching%setup_nlo_environment ()
call matching%grid%init ([matching%settings%size_grid_xi, &
matching%settings%size_grid_y, matching%process_deps%n_alr])
call matching%compute_lambda5MSB ()
call matching%compute_lambda2_gen ()
call matching%setup_sudakovs ()
end subroutine powheg_matching_prepare_for_events
@ %def powheg_matching_prepare_for_events
@ Computes the scale $\Lambda$ used for the (log integrated) UBFs.
By construction, it is always $p_{T,\text{min}} > \Lambda$.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: compute_lambda2_gen => powheg_matching_compute_lambda2_gen
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_compute_lambda2_gen (matching)
class(powheg_matching_t), intent(inout) :: matching
end subroutine powheg_matching_compute_lambda2_gen
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_compute_lambda2_gen (matching)
class(powheg_matching_t), intent(inout) :: matching
real(default) :: scale_to_relate2, alpha_s
scale_to_relate2 = (2*matching%process_deps%lambda5MSB)**2
alpha_s = get_alpha_s (matching%qcd, scale_to_relate2, 3)
matching%process_deps%lambda2_gen = exp (- one / (b0rad () * alpha_s)) * &
scale_to_relate2
end subroutine powheg_matching_compute_lambda2_gen
@ %def powheg_matching_compute_lambda2_gen
@ Computes the scale $\Lambda^{(5)}_{\overline{MS}}$ used to determine the scale
at which we relate $\alpha_s^{\text{rad}}$ and $\alpha_s^{\text{true}}$.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: compute_lambda5MSB => powheg_matching_compute_lambda5MSB
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_compute_lambda5MSB (matching)
class(powheg_matching_t), intent(inout) :: matching
end subroutine powheg_matching_compute_lambda5MSB
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_compute_lambda5MSB (matching)
class(powheg_matching_t), intent(inout) :: matching
real(default) :: alpha_s
integer :: nf, order
logical :: print_once = .true.
if (matching%settings%lambda == 0) then
alpha_s = matching%qcd%alpha%get(MZ_REF)
select type (alpha => matching%qcd%alpha)
type is (alpha_qcd_from_scale_t)
order = alpha%order
type is (alpha_qcd_from_lambda_t)
order = alpha%order
type is (alpha_qcd_lhapdf_t)
order = alpha%get_order ()
class default
if (print_once) then
call msg_warning ("compute_lambda5MSB: alpha_qcd not running!" // &
" Assuming LO (1-loop) running!")
print_once = .false.
end if
order = 0
end select
nf = 5
matching%process_deps%lambda5MSB = lambda_qcd(alpha_s, MZ_REF, nf, order)
else if (matching%settings%lambda > 0) then
matching%process_deps%lambda5MSB = matching%settings%lambda
else
call msg_fatal ("compute_lambda5MSB: lambda5MSB < 0")
end if
end subroutine powheg_matching_compute_lambda5MSB
@ %def powheg_matching_compute_lambda5MSB
@ This is the setup of the process dependencies stored for the matching.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: setup_nlo_environment => powheg_matching_setup_nlo_environment
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_setup_nlo_environment (matching)
class(powheg_matching_t), intent(inout) :: matching
end subroutine powheg_matching_setup_nlo_environment
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_setup_nlo_environment (matching)
class(powheg_matching_t), intent(inout) :: matching
integer :: n_tot_born, n_tot_real
integer :: i_phs, i_term_real, i_term
integer :: n_phs, nlo_type
if (debug_on) call msg_debug &
(D_MATCHING, "powheg_matching_setup_nlo_environment")
select type (pcm_work => matching%process_instance%pcm_work)
class is (pcm_nlo_workspace_t)
matching%process_deps%sqrts = matching%process_instance%get_sqrts ()
select type (pcm => matching%process_instance%pcm)
type is (pcm_nlo_t)
matching%process_deps%n_alr = pcm%region_data%n_regions
n_tot_born = pcm%region_data%n_legs_born
n_tot_real = pcm%region_data%n_legs_real
call pcm%setup_phs_generator (pcm_work, &
matching%phs_fks_generator, matching%process_deps%sqrts, &
singular_jacobian = matching%settings%singular_jacobian)
end select
associate (instance => matching%process_instance)
i_term_real = instance%process%get_first_real_component ()
associate (process_deps => matching%process_deps)
select type (phs => instance%kin(i_term_real)%phs)
type is (phs_fks_t)
n_phs = size (phs%phs_identifiers)
allocate (process_deps%phs_identifiers (n_phs))
process_deps%phs_identifiers = phs%phs_identifiers
end select
call instance%process%get_coupling_powers(process_deps%alpha_power, &
process_deps%alphas_power)
allocate (matching%process_deps%alr_to_i_phs &
(size (pcm_work%real_kinematics%alr_to_i_phs)))
process_deps%alr_to_i_phs = pcm_work%real_kinematics%alr_to_i_phs
allocate (process_deps%i_term_real (n_phs))
i_phs = 1
do i_term = 1, size (instance%term)
nlo_type = instance%term(i_term)%nlo_type
if (nlo_type == BORN) then
process_deps%i_term_born = i_term
else if (nlo_type == NLO_REAL) then
if (instance%kin(i_term)%emitter >= 0) then
process_deps%i_term_real(i_phs) = i_term
i_phs = i_phs + 1
end if
end if
end do
end associate
end associate
call matching%event_deps%p_born_lab%init (n_tot_born, 1)
call matching%event_deps%p_born_cms%init (n_tot_born, 1)
call matching%event_deps%p_real_lab%init (n_tot_real, n_phs)
call matching%event_deps%p_real_cms%init (n_tot_real, n_phs)
end select
end subroutine powheg_matching_setup_nlo_environment
@ %def powheg_matching_setup_nlo_environment
@ Copy momenta from [[event_deps]] to [[real_kinematics]]
for them to be available for the [[int_hard]] in [[compute_sqme_rad]].
<<POWHEG matching: powheg matching: TBP>>=
procedure :: copy_momenta => powheg_matching_copy_momenta
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_copy_momenta (matching, i_phs)
class(powheg_matching_t), intent(inout) :: matching
integer, intent(in) :: i_phs
end subroutine powheg_matching_copy_momenta
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_copy_momenta (matching, i_phs)
class(powheg_matching_t), intent(inout) :: matching
integer, intent(in) :: i_phs
select type (pcm_work => matching%process_instance%pcm_work)
class is (pcm_nlo_workspace_t)
call pcm_work%real_kinematics%p_real_cms%set_momenta &
(i_phs, matching%event_deps%p_real_cms%get_momenta (i_phs))
call pcm_work%real_kinematics%p_real_lab%set_momenta &
(i_phs, matching%event_deps%p_real_lab%get_momenta (i_phs))
end select
end subroutine powheg_matching_copy_momenta
@ %def powheg_matching_copy_momenta
@ [[qcd%alpha%get]] should implement a variable-flavor result and
optionally return [[n_flavors]] that are active at the scale.
Optionally takes [[nf]] as input preceeding the PDFs value.
We need this to compute $\alpha_s^{rad}$ always with [[nf=3]].
<<POWHEG matching: procedures>>=
function get_alpha_s (qcd, scale2, nf_in, improve_nll_opt) result (alpha_s)
real(default) :: alpha_s
class(qcd_t), intent(in) :: qcd
real(default), intent(in) :: scale2
integer, optional, intent(in) :: nf_in
logical, optional, intent(in) :: improve_nll_opt
logical :: improve_nll
real(default) :: mb, mc
integer :: nf
logical :: print_once = .true.
! TODO: (bcn 2015-01-30) implement variable flavor alpha_s for all types
improve_nll = .true.; if (present(improve_nll_opt)) improve_nll = improve_nll_opt
alpha_s = qcd%alpha%get (sqrt(scale2))
select type (alpha => qcd%alpha)
type is (alpha_qcd_from_scale_t)
nf = alpha%nf
type is (alpha_qcd_from_lambda_t)
nf = alpha%nf
type is (alpha_qcd_lhapdf_t)
mc = alpha%get_qmass(4)
mb = alpha%get_qmass(5)
if (scale2 > mb**2) then
nf = 5
elseif (scale2 > mc**2) then
nf = 4
else
nf = 3
end if
class default
if (print_once) then
call msg_warning ("get_alpha_s: QCD type is not running!" // &
" Assuming 5-flavors and LO (1-loop) running!")
print_once = .false.
end if
nf = 5
end select
if (present(nf_in)) then
nf = nf_in
end if
if (improve_nll) then
alpha_s = improve_nll_accuracy (alpha_s, nf)
end if
end function get_alpha_s
@ %def get_alpha_s
@ See Eq. (4.31) in [[0709.2092]]. Should be used everywhere in the Sudakov
exponent.
<<POWHEG matching: procedures>>=
pure function improve_nll_accuracy (alpha_s, n_flavors) result (alpha_s_imp)
real(default) :: alpha_s_imp
real(default), intent(in) :: alpha_s
integer, intent(in) :: n_flavors
alpha_s_imp = alpha_s * (one + alpha_s / (two*pi) * &
((67.0_default/18 - pi**2/6) * CA - five/9 * n_flavors))
end function improve_nll_accuracy
@ %def improve_nll_accuracy
@ Wrapper for $b_0(n_f=5)$ from the [[sm_physics]] module.
It is fixed to $n_f=5$ for radiation generation and will be
reweighted to the more precise $\alpha_s$.
<<POWHEG matching: procedures>>=
pure function b0rad () result (b0)
real(default) :: b0
b0 = coeff_b0(five)
end function b0rad
@ %def b0rad
@ Computes the overestimated $\alpha_s$ for the sudakov before the $\alpha_s$-Veto.
We do not NLL-correct $\alpha_s$ again. We did so already when computing [[lambda2_gen]].
<<POWHEG matching: sudakov: TBP>>=
procedure :: alpha_s_rad => sudakov_alpha_s_rad
<<POWHEG matching: sub interfaces>>=
elemental module function sudakov_alpha_s_rad (sudakov, scale2) result (alpha_s_rad)
real(default) :: alpha_s_rad
class(sudakov_t), intent(in) :: sudakov
real(default), intent(in) :: scale2
end function sudakov_alpha_s_rad
<<POWHEG matching: procedures>>=
elemental module function sudakov_alpha_s_rad (sudakov, scale2) result (alpha_s_rad)
real(default) :: alpha_s_rad
class(sudakov_t), intent(in) :: sudakov
real(default), intent(in) :: scale2
alpha_s_rad = one / (b0rad () * log (scale2 / sudakov%process_deps%lambda2_gen))
end function sudakov_alpha_s_rad
@ %def sudakov_alpha_s_rad
@
\subsection{POWHEG hook}
We provide a POWHEG hook to be called by [[process_instance_evaluate]] to
prefill the adaptation grid.
We store the actual [[powheg]] object, which does the computations.
<<POWHEG matching: public>>=
public :: powheg_matching_hook_t
<<POWHEG matching: types>>=
type, extends(process_instance_hook_t) :: powheg_matching_hook_t
type(string_t) :: process_name
type(powheg_matching_t) :: powheg
contains
<<POWHEG matching: powheg matching hook: TBP>>
end type powheg_matching_hook_t
@ %def powheg_matching_t
@ Init the hook. The init procedure will be called in [[setup_process]], after
everything is set up.
Additionally, we have to include [[var_list]] in order to retrieve the grid size
in [[xi]] and [[y]].
<<POWHEG matching: powheg matching hook: TBP>>=
procedure :: init => powheg_matching_hook_init
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_hook_init (hook, var_list, &
instance, pdf_data)
class(powheg_matching_hook_t), intent(inout), target :: hook
type(var_list_t), intent(in) :: var_list
class(process_instance_t), intent(in), target :: instance
type(pdf_data_t), intent(in), optional :: pdf_data
end subroutine powheg_matching_hook_init
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_hook_init (hook, var_list, &
instance, pdf_data)
class(powheg_matching_hook_t), intent(inout), target :: hook
type(var_list_t), intent(in) :: var_list
class(process_instance_t), intent(in), target :: instance
type(pdf_data_t), intent(in), optional :: pdf_data
if (debug_on) call msg_debug (D_MATCHING, "powheg_matching_hook_init")
hook%process_name = instance%get_process_name ()
call hook%powheg%init (var_list, hook%process_name)
hook%powheg%qcd = instance%get_qcd ()
call hook%powheg%connect (instance)
hook%powheg%process_deps%lab_is_cm = &
hook%powheg%process_instance%lab_is_cm (1)
if (present(pdf_data)) then
hook%powheg%process_deps%pdf_data = pdf_data
end if
call hook%powheg%prepare_for_events ()
end subroutine powheg_matching_hook_init
@ %def powheg_matching_hook_init
@ We save the filled grid to file, such that it can be retrieved later on.
The hook object will be deallocated when the instance gets deallocated.
<<POWHEG matching: powheg matching hook: TBP>>=
procedure :: final => powheg_matching_hook_final
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_hook_final (hook)
class(powheg_matching_hook_t), intent(inout) :: hook
end subroutine powheg_matching_hook_final
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_hook_final (hook)
class(powheg_matching_hook_t), intent(inout) :: hook
type(string_t) :: filename
if (debug_on) call msg_debug (D_MATCHING, "powheg_matching_hook_final")
<<POWHEG matching: powheg matching hook final: reduce>>
call hook%powheg%save_grids ()
end subroutine powheg_matching_hook_final
@ %def powheg_matching_hook_final
@
<<POWHEG matching: powheg matching hook final: reduce>>=
@ Reduce all grids to a single grid by using [[MPI_MAX]] on each element.
<<MPI: POWHEG matching: powheg matching hook final: reduce>>=
call hook%powheg%grid%mpi_reduce (MPI_MAX)
@ This routine fills each bin of the POWHEG normalization grid $\{\tilde\xi, \tilde y\}$
@ such that
\begin{equation}
N(\{\tilde\xi, \tilde y\}) = \max_{\forall \xi,y \in \{\tilde\xi, \tilde y\}}
\frac{\mathcal{R}(\xi,y)\mathcal{J}(\xi,y)}{\mathcal{B}\,U(\xi,y,\alpha_s^\text{true})}
\end{equation}
where $\mathcal{R}(\xi,y)$ is the real cross section [[sqme_real]],
$\mathcal{B}$ is the Born cross section [[sqme_born]],
$\mathcal{J}$ is the Jacobian and $U$ the upper bounding function [[ubf]].
For each underlying Born $f_b$, there is a number of radiation regions.
A radiation region rr may correspond to multiple $\alpha_r$s. The phase
space only depends upon the radiation region kinematics rr and not on
the specific $\alpha_r$. $\alpha_r$ can be picked in the set
$\{\alpha_r|f_b,\text{rr}\}$ proportional to their $R_{\alpha_r}$.
For now, we simplify things though and just work with the $\alpha_r$.
References:
\begin{itemize}
\item \texttt{[1002.2581]}, Sec. 7.1
\item Bijans Thesis, Sec. 3.3 and B.2
\end{itemize}
In cases where just the Born kinematic failed the cuts, $\mathcal{B}$ was artificially set
to zero.
Unfortunately, we lost information about the value of [[sqme_born]] in these cases
but we assume that the generator cuts applied for parton showering are weak cuts to
avoid divergent phase space regions, thus $\mathcal{B}$ is large and does not influence $N$
so we can skip these phase space points.
A more appropriate way to solve this problem of Born zeroes is given by the real partition.
With real partition, there are two possible cases if $\mathcal{B} = 0$: if the real phase
space point belongs to the real singular, the real kinematic is Born-like and very likely
also fails the cuts. If the real kinematic is not Born-like, it belongs to the real finite.
In both cases, it is $\mathcal{R} = \mathcal{B} = 0$ and we can savely skip the phase space
point.
In cases where just the real kinematic failed the cuts, $\mathcal{R}$ was artificially set
to zero and we have no way to recover it. We skip these phase space points too. If we apply
the same cuts during integration and event generation, these points are not relevant.
We also skip points where either matrix element is negative. If just one of both is negative,
their ratio is negative and thus cannot possibly be relevant for the grid. If both are negative,
we are in an unphysical region for the PDFs.
We also need to correct all scale dependences of [[sqme_born]] and [[sqme_real]] from
the process' scale to $p_T$ as this is the scale of the entire Sudakov.
This affects the PDFs and also $\alpha_s$.
<<POWHEG matching: powheg matching hook: TBP>>=
procedure :: evaluate => powheg_matching_hook_evaluate
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_matching_hook_evaluate (hook, instance)
class(powheg_matching_hook_t), intent(inout) :: hook
class(process_instance_t), intent(in), target :: instance
end subroutine powheg_matching_hook_evaluate
<<POWHEG matching: procedures>>=
module subroutine powheg_matching_hook_evaluate (hook, instance)
class(powheg_matching_hook_t), intent(inout) :: hook
class(process_instance_t), intent(in), target :: instance
type(vector4_t), dimension(:), allocatable :: p_hard_born
real(default), dimension(:), allocatable :: x
real(default) :: kt2, xi, y, xi_max, onepy, onemy
real(default), dimension(2) :: x_real
real(default) :: sqme_born, sqme_real_x_jac
real(default) :: muren_born, mufac_born, muren_real, mufac_real
real(default) :: alpha_s_kt, alpha_s_muren_born, alpha_s_muren_real
real(default) :: f_alr, norm, ubf
real(default) :: r_xi, r_y
real(double), dimension(-6:6) :: pdf_dbl
real(default), dimension(2) :: pdf_born_mufac, pdf_born_kt, &
pdf_real_mufac, pdf_real_kt
real(double) :: x_dbl, q_dbl
integer, dimension(2) :: flv_born, flv_real
integer :: alr, i_phs, n_x, i_term_born, i_term_real, em
integer :: alphas_power, i_uborn
logical :: is_isr
if (instance%get_active_component_type () == COMP_REAL_FIN) return
associate (powheg => hook%powheg)
i_term_born = powheg%process_deps%i_term_born
allocate (p_hard_born (size (instance%get_p_hard (i_term_born))))
p_hard_born = instance%get_p_hard (i_term_born)
call powheg%update (p_hard_born)
do alr = 1, powheg%process_deps%n_alr
i_phs = powheg%process_deps%alr_to_i_phs (alr)
i_term_real = powheg%process_deps%i_term_real(i_phs)
select type (phs => instance%kin(i_term_real)%phs)
type is (phs_fks_t)
call phs%generator%get_radiation_variables (i_phs, xi, y)
end select
call powheg%update_sudakovs (alr, i_phs, y)
kt2 = powheg%sudakov(alr)%s%kt2 (xi, y)
if (kt2 >= powheg%settings%pt2_min) then
select type (pcm => instance%pcm)
type is (pcm_nlo_t)
associate (reg_data => pcm%region_data)
i_uborn = reg_data%regions(alr)%uborn_index
end associate
end select
is_isr = instance%kin(i_term_real)%emitter <= instance%kin(i_term_real)%n_in
select type (pcm_work => instance%pcm_work)
class is (pcm_nlo_workspace_t)
sqme_born = pcm_work%real_sub%sqme_born(i_uborn)
sqme_real_x_jac = pcm_work%real_sub%sqme_real_arr(alr)
sqme_real_x_jac = pcm_work%powheg_kinematic_factors_real &
(sqme_real_x_jac, alr)
end select
if (sqme_born == 0 .or. sqme_real_x_jac == 0) then
cycle
end if
associate (s => powheg%sudakov(alr)%s)
alpha_s_kt = s%alpha_s (kt2, use_correct=.true.)
muren_born = instance%term(i_term_born)%get_ren_scale ()
mufac_born = instance%term(i_term_born)%get_fac_scale ()
muren_real = instance%term(i_term_real)%get_ren_scale ()
mufac_real = instance%term(i_term_real)%get_fac_scale ()
alpha_s_muren_born = s%alpha_s (muren_born**2, use_correct=.true., improve_nll=.false.)
alpha_s_muren_real = s%alpha_s (muren_real**2, use_correct=.true., improve_nll=.false.)
ubf = s%upper_bound_func (xi, y, alpha_s_kt)
end associate
!!! Correct all factors of alphas(muren) to alphas(kt).
alphas_power = powheg%process_deps%alphas_power
sqme_born = (alpha_s_kt / alpha_s_muren_born)**alphas_power * sqme_born
sqme_real_x_jac = (alpha_s_kt / alpha_s_muren_real)**(alphas_power+1) * sqme_real_x_jac
!!! Also correct the PDFs previously computed at mufac instead of kt
select type (pcm => instance%pcm)
type is (pcm_nlo_t)
if (pcm%has_pdfs) then
associate (reg_data => pcm%region_data)
flv_born = reg_data%regions(alr)%flst_uborn%flst(1:2)
where (flv_born == 21) flv_born = 0
flv_real = reg_data%regions(alr)%flst_real%flst(1:2)
where (flv_real == 21) flv_real = 0
end associate
associate (pdf_data => powheg%process_deps%pdf_data, &
x_born => powheg%event_deps%x_born)
if (.not. pdfs_valid(instance, pdf_data, alr, &
sqrt(kt2), x_born, is_isr)) cycle
do em = 1, 2
x_dbl = x_born(em) ; q_dbl = mufac_born
call pdf_data%evolve(x_dbl, q_dbl, pdf_dbl)
pdf_born_mufac(em) = pdf_dbl(flv_born(em)) / x_born(em)
x_dbl = x_born(em) ; q_dbl = sqrt(kt2)
call pdf_data%evolve(x_dbl, q_dbl, pdf_dbl)
pdf_born_kt(em) = pdf_dbl(flv_born(em)) / x_born(em)
end do
if (is_isr) then
onepy = one + y; onemy = one - y
x_real(1) = x_born(1) * sqrt ((two - xi * onemy) / (two - xi * onepy))
x_real(2) = x_born(2) * sqrt ((two - xi * onepy) / (two - xi * onemy))
x_real = x_real / sqrt (one - xi)
else
x_real = x_born
end if
do em = 1, 2
x_dbl = x_real(em) ; q_dbl = mufac_real
call pdf_data%evolve(x_dbl, q_dbl, pdf_dbl)
pdf_real_mufac(em) = pdf_dbl(flv_real(em)) / x_real(em)
x_dbl = x_real(em) ; q_dbl = sqrt(kt2)
call pdf_data%evolve(x_dbl, q_dbl, pdf_dbl)
pdf_real_kt(em) = pdf_dbl(flv_real(em)) / x_real(em)
end do
sqme_born = pdf_born_kt(1) * pdf_born_kt(2) / &
(pdf_born_mufac(1) * pdf_born_mufac(2)) * sqme_born
sqme_real_x_jac = pdf_real_kt(1) * pdf_real_kt(2) / &
(pdf_real_mufac(1) * pdf_real_mufac(2)) * sqme_real_x_jac
end associate
end if
end select
if (sqme_born <= 0 .or. sqme_real_x_jac <= 0) then
cycle
end if
norm = sqme_real_x_jac / (sqme_born * ubf)
f_alr = (one * alr) / powheg%process_deps%n_alr - tiny_07
r_y = abs(y)
select type (pcm_work => instance%pcm_work)
class is (pcm_nlo_workspace_t)
xi_max = min(pcm_work%get_xi_max (alr), 1 - tiny_07)
end select
if (xi > xi_max) then
r_xi = 1
else
r_xi = log(1 - xi) / log(1 - xi_max)
end if
call powheg%grid%update_maxima ([r_xi, r_y, f_alr], norm)
end if
end do
end associate
contains
<<POWHEG matching: powheg matching hook: evaluate: contained>>
end subroutine powheg_matching_hook_evaluate
@ %def powheg_matching_hook_evaluate
@ In some phase space point, the quark PDF may vanish although the gluon PDF does not.
This may lead to very large ratios $\mathcal{R} / \mathcal{B}$ which may spoil
the reweighting performance of the POWHEG grid.
Excluding these values when filling the grid is a minor approximation
with a huge performance gain.
The PDF veto we perform is independent on the actual emitter to not artificially
favor specific ALRs.
<<POWHEG matching: powheg matching hook: evaluate: contained>>=
function pdfs_valid (instance, pdf_data, alr, q, x, is_isr) result (valid)
logical :: valid
class(process_instance_t), intent(in), target :: instance
type(pdf_data_t), intent(inout) :: pdf_data
integer, intent(in) :: alr
real(default), intent(in) :: q
real(default), dimension(2), intent(in) :: x
real(double) :: q_dbl
real(double), dimension(2) :: x_dbl
logical, intent(in) :: is_isr
real(default) :: sum_pdf_q
real(default), dimension(-6:6) :: pdf
real(double), dimension(-6:6) :: pdf_dbl
integer :: flv_born_em, em, i_q
logical :: warned_once = .false.
valid = .true.
if (is_isr) then
if (q**2 < two .or. any(x > 0.9_default)) then
valid = .false.
return
end if
x_dbl = x
q_dbl = q
do em = 1, 2
call pdf_data%evolve(x_dbl(em), q_dbl, pdf_dbl)
pdf = pdf_dbl / x(em)
select type (pcm => instance%pcm)
type is (pcm_nlo_t)
flv_born_em = pcm%region_data%regions(alr)%flst_uborn%flst(em)
end select
if (is_gluon(flv_born_em)) then
sum_pdf_q = 0
do i_q = 1, 6
sum_pdf_q = sum_pdf_q + pdf(-i_q) + pdf(i_q)
end do
if (sum_pdf_q * x(em) * (1-x(em)) > 30._default * pdf(0)) then
valid = .false.
return
end if
elseif (is_quark(flv_born_em)) then
if (pdf(0) * x(em) * (1-x(em)) > 30._default * pdf(flv_born_em)) then
valid = .false.
return
end if
else
if (.not. warned_once) then
call msg_warning ("powheg_matching_hook_evaluate: unexpected emitter flavor")
warned_once = .true.
end if
end if
end do
end if
end function pdfs_valid
@ %def pdfs_valid
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[powheg_matching_ut.f90]]>>=
<<File header>>
module powheg_matching_ut
use unit_tests
use powheg_matching_uti
<<Standard module head>>
<<POWHEG matching: public test>>
contains
<<POWHEG matching: test driver>>
end module powheg_matching_ut
@ %def powheg_matching_ut
@
<<[[powheg_matching_uti.f90]]>>=
<<File header>>
module powheg_matching_uti
<<Use kinds>>
<<Use strings>>
use constants, only: zero, one
use lorentz
use physics_defs, only: LAMBDA_QCD_REF
use sm_qcd
use subevents, only: PRT_INCOMING, PRT_OUTGOING
use model_data
use particles
use rng_base
use variables
use shower_base
use shower_core
use powheg_matching
use rng_base_ut, only: rng_test_factory_t
<<Standard module head>>
<<POWHEG matching: test declarations>>
contains
<<POWHEG matching: tests>>
end module powheg_matching_uti
@ %def powheg_matching_ut
@ API: driver for the unit tests below.
<<POWHEG matching: public test>>=
public :: powheg_test
<<POWHEG matching: test driver>>=
subroutine powheg_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<POWHEG matching: execute tests>>
end subroutine powheg_test
@ %def powheg_test
@
\subsubsection{Initialization}
There are no Powheg unit tests so far.
\subsubsection{Compare generated emission with Sudakov form factor}
This is a nontrivial test of the generation algorithm and should be
independent of the used upper bounding function (as long as all
singularities are included).
It runs for an extensive amount of time generating a file [[sudakov.dat]] containing
a histogram for the Sudakov factor in bins of the radiation's transverse momentum $p_T^2$.
So far, it is only designed to work for lepton collisions without beam spectra and cuts.
In its current state however, it fills the histogram with either $1$ or [[NaN]] as the
[[p_hard]] received in [[term_instance_evaluate_interaction]] is identically zero.
<<POWHEG matching: powheg matching: TBP>>=
procedure :: test_sudakov => powheg_test_sudakov
<<POWHEG matching: sub interfaces>>=
module subroutine powheg_test_sudakov (powheg)
class(powheg_matching_t), intent(inout) :: powheg
end subroutine powheg_test_sudakov
<<POWHEG matching: procedures>>=
module subroutine powheg_test_sudakov (powheg)
class(powheg_matching_t), intent(inout) :: powheg
integer :: n_calls1, n_calls2
integer, parameter :: n_bins = 20
real(default) :: sqme_real_x_jac, sqme_born
type(vector4_t), dimension(:), allocatable :: p_born
real(default), dimension(3) :: random
real(default) :: xi, y
integer :: i_call, i_bin, alr, emitter, i_phs
real(default) :: alpha_s, kT2, weight
real(default) :: pt2_min, s, random_jacobian
real(default), dimension(n_bins) :: histo1, histo2, histo1sq, histo2sq
real(default), dimension(n_bins) :: tmp
integer :: i_strip, n_in_strip, n_strips
real(default), dimension(n_bins) :: average, average_sq, error
real(default), dimension(n_bins) :: &
sudakov_0, sudakov_p, sudakov_m, rel_error
integer :: u
p_born = powheg%event_deps%p_born_lab%get_momenta (1)
s = powheg%event_deps%s_hat
pt2_min = powheg%settings%pt2_min
n_calls1 = 100000; n_calls2 = 1000000
histo1 = zero; histo2 = zero; histo1sq = zero; histo2sq = zero
n_strips = 10
call compute_integrals ()
call generate_emissions ()
call write_to_screen_and_file ()
contains
<<POWHEG matching: powheg test sudakov: procedures>>
end subroutine powheg_test_sudakov
@ %def powheg_test_sudakov
@ This determines the binning of the Sudakov histogram.
Linear and logarithmic binning are available.
<<POWHEG matching: powheg test sudakov: procedures>>=
pure function binning (i) result (pt2)
real(default) :: pt2
integer, intent(in) :: i
!pt2 = pt2_min + (s-pt2_min) * (i-1) / (n_bins-1)
pt2 = pt2_min * exp (log (s / pt2_min) * (i-1) / (n_bins-1))
end function
@ %def binning
@
<<POWHEG matching: powheg test sudakov: procedures>>=
subroutine compute_integrals ()
write (msg_buffer, "(A)") "POWHEG: test_sudakov: Computing integrals"
call msg_message ()
select type (pcm_work => powheg%process_instance%pcm_work)
class is (pcm_nlo_workspace_t)
associate (fks => powheg%phs_fks_generator)
do i_call = 1, n_calls1
do alr = 1, powheg%process_deps%n_alr
call powheg%rng%generate (random)
select type (pcm => powheg%process_instance%pcm)
type is (pcm_nlo_t)
emitter = pcm%region_data%get_emitter (alr)
i_phs = powheg%process_deps%alr_to_i_phs(alr)
end select
!!! The sudakov test works only with lepton collisions without beam spectra
!!! so we can identify the cms and lab momenta.
powheg%event_deps%p_real_lab = powheg%event_deps%p_real_cms
call powheg%copy_momenta (i_phs)
call fks%get_radiation_variables (i_phs, xi, y)
kT2 = powheg%sudakov(alr)%s%kt2(xi, y)
if (kT2 >= pt2_min .and. xi < one - tiny_07) then
alpha_s = get_alpha_s (powheg%qcd, kT2)
sqme_born = powheg%event_deps%sqme_born(alr)
sqme_real_x_jac = powheg%compute_sqme_real (alr, sqrt(kT2))
random_jacobian = pcm_work%real_kinematics%jac_rand (emitter)
weight = sqme_real_x_jac * random_jacobian / sqme_born
do i_bin = 1, n_bins
if (kT2 > binning(i_bin)) then
histo1(i_bin) = histo1(i_bin) + weight
histo1sq(i_bin) = histo1sq(i_bin) + weight**2
end if
end do
end if
! Do not cycle since there is a Heaviside in the exponent
end do
call msg_show_progress (i_call, n_calls1)
end do
end associate
end select
average = histo1 / n_calls1
average_sq = histo1sq / n_calls1
error = sqrt ((average_sq - average**2) / n_calls1)
sudakov_0 = exp(-average)
sudakov_p = exp(-(average + error))
sudakov_m = exp(-(average - error))
rel_error = (sudakov_m - sudakov_p) / (2 * sudakov_0) * 100
end subroutine compute_integrals
@ %def compute_integrals
@
<<POWHEG matching: powheg test sudakov: procedures>>=
subroutine generate_emissions ()
write (msg_buffer, "(A)") "POWHEG: test_sudakov: Generating emissions"
call msg_message ()
do i_strip = 1, n_strips
tmp = 0
n_in_strip = n_calls2 / n_strips
do i_call = 1, n_in_strip
if (signal_is_pending ()) return
call powheg%generate_emission (pt2_generated = kT2)
do i_bin = 1, n_bins
if (kT2 > binning(i_bin)) then
tmp(i_bin) = tmp(i_bin) + 1
end if
end do
end do
tmp = one - (one * tmp) / n_in_strip
histo2 = histo2 + tmp
histo2sq = histo2sq + tmp**2
call msg_show_progress (i_strip, n_strips)
end do
average = histo2 / n_strips
average_sq = histo2sq / n_strips
error = sqrt ((average_sq - average**2) / n_strips)
end subroutine generate_emissions
@ %def generate_emissions
@
<<POWHEG matching: powheg test sudakov: procedures>>=
subroutine write_to_screen_and_file ()
u = free_unit ()
open (file='sudakov.dat', unit=u, action='write')
print *, 'exp(-Integrated R/B)-distribution: '
print *, 'pT2 sudakov_+ sudakov_0 sudakov_- rel_err[%]: '
do i_bin = 1, n_bins
print *, binning(i_bin), &
sudakov_p(i_bin), sudakov_0(i_bin), sudakov_m(i_bin), &
rel_error(i_bin)
write (u, "(6(" // FMT_16 // ",2X))") binning(i_bin), &
sudakov_p(i_bin), sudakov_0(i_bin), sudakov_m(i_bin), &
average(i_bin), error(i_bin)
end do
close (u)
print *, '*******************************'
print *, 'Noemission probability: '
do i_bin = 1, n_bins
print *, binning (i_bin), average (i_bin), error(i_bin)
end do
end subroutine write_to_screen_and_file
@ %def write_to_screen_and_file
@

File Metadata

Mime Type
application/octet-stream
Expires
Fri, May 3, 9:12 PM (1 d, 23 h)
Storage Engine
chunks
Storage Format
Chunks
Storage Handle
gJuy3tzyJjOy
Default Alt Text
(4 MB)

Event Timeline