Page MenuHomeHEPForge
Files F8310295

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
Index: trunk/ChangeLog
===================================================================
--- trunk/ChangeLog (revision 8249)
+++ trunk/ChangeLog (revision 8250)
@@ -1,1848 +1,1852 @@
ChangeLog -- Summary of changes to the WHIZARD package
Use svn log to see detailed changes.
Version 2.8.0
2019-05-31
RELEASE: version 2.8.0
+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
Bugfix 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
Bugfix 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
Bugfix for generator status in LCIO
##################################################################
2016-11-28
RELEASE: version 2.4.0
2016-11-24
Bugfix for OpenLoops interface: EW scheme
is set by WHIZARD
Bugfixes 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
Bugfix 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
Bugfix 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
Bugfix 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
Bugfix 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
Bugfix 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/process_integration/process_integration.nw
===================================================================
--- trunk/src/process_integration/process_integration.nw (revision 8249)
+++ trunk/src/process_integration/process_integration.nw (revision 8250)
@@ -1,19165 +1,19165 @@
% -*- 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 constants, only: zero, one
use io_units
use format_utils, only: write_separator
use diagnostics
use lorentz
use subevents
use variables
use flavors
use quantum_numbers
use interactions
use particles
use expr_base
<<Standard module head>>
<<Subevt expr: public>>
<<Subevt expr: types>>
<<Subevt expr: interfaces>>
contains
<<Subevt expr: procedures>>
end module subevt_expr
@ %def subevt_expr
@
\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: procedures>>=
subroutine subevt_expr_write (object, unit, pacified)
class(subevt_expr_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacified
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Local variables:"
call write_separator (u)
call var_list_write (object%var_list, u, follow_link=.false., &
pacified = pacified)
call write_separator (u)
if (object%subevt_filled) then
call object%subevt_t%write (u, pacified = pacified)
if (object%has_selection) then
call write_separator (u)
write (u, "(1x,A)") "Selection expression:"
call write_separator (u)
call object%selection%write (u)
end if
else
write (u, "(1x,A)") "subevt: [undefined]"
end if
end subroutine subevt_expr_write
@ %def subevt_expr_write
@ Finalizer.
<<Subevt expr: subevt expr: TBP>>=
procedure (subevt_expr_final), deferred :: final
procedure :: base_final => subevt_expr_final
<<Subevt expr: procedures>>=
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: procedures>>=
subroutine subevt_expr_setup_vars (expr, sqrts)
class(subevt_expr_t), intent(inout), target :: expr
real(default), intent(in) :: sqrts
call expr%var_list%final ()
call var_list_append_real (expr%var_list, &
var_str ("sqrts"), sqrts, &
locked = .true., verbose = .false., intrinsic = .true.)
call var_list_append_real_ptr (expr%var_list, &
var_str ("sqrts_hat"), expr%sqrts_hat, &
is_known = expr%subevt_filled, &
locked = .true., verbose = .false., intrinsic = .true.)
call var_list_append_int_ptr (expr%var_list, &
var_str ("n_in"), expr%n_in, &
is_known = expr%subevt_filled, &
locked = .true., verbose = .false., intrinsic = .true.)
call var_list_append_int_ptr (expr%var_list, &
var_str ("n_out"), expr%n_out, &
is_known = expr%subevt_filled, &
locked = .true., verbose = .false., intrinsic = .true.)
call var_list_append_int_ptr (expr%var_list, &
var_str ("n_tot"), expr%n_tot, &
is_known = expr%subevt_filled, &
locked = .true., verbose = .false., intrinsic = .true.)
end subroutine subevt_expr_setup_vars
@ %def subevt_expr_setup_vars
@ Append the subevent expr (its base-type core) itself to the variable
list, if it is not yet present.
<<Subevt expr: subevt expr: TBP>>=
procedure :: setup_var_self => subevt_expr_setup_var_self
<<Subevt expr: procedures>>=
subroutine subevt_expr_setup_var_self (expr)
class(subevt_expr_t), intent(inout), target :: expr
if (.not. expr%var_list%contains (var_str ("@evt"))) then
call var_list_append_subevt_ptr &
(expr%var_list, &
var_str ("@evt"), expr%subevt_t, &
is_known = expr%subevt_filled, &
locked = .true., verbose = .false., intrinsic=.true.)
end if
end subroutine subevt_expr_setup_var_self
@ %def subevt_expr_setup_var_self
@ Link a variable list to the local one. This could be done event by event,
but before evaluating expressions.
<<Subevt expr: subevt expr: TBP>>=
procedure :: link_var_list => subevt_expr_link_var_list
<<Subevt expr: procedures>>=
subroutine subevt_expr_link_var_list (expr, var_list)
class(subevt_expr_t), intent(inout) :: expr
type(var_list_t), intent(in), target :: var_list
call expr%var_list%link (var_list)
end subroutine subevt_expr_link_var_list
@ %def subevt_expr_link_var_list
@ Compile the selection expression. If there is no expression, the build
method won't allocate the expression object.
<<Subevt expr: subevt expr: TBP>>=
procedure :: setup_selection => subevt_expr_setup_selection
<<Subevt expr: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine parton_expr_setup_scale (expr, ef_scale)
class(parton_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_scale
call ef_scale%build (expr%scale)
if (allocated (expr%scale)) then
call expr%setup_var_self ()
call expr%scale%setup_expr (expr%var_list)
expr%has_scale = .true.
end if
end subroutine parton_expr_setup_scale
subroutine parton_expr_setup_fac_scale (expr, ef_fac_scale)
class(parton_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_fac_scale
call ef_fac_scale%build (expr%fac_scale)
if (allocated (expr%fac_scale)) then
call expr%setup_var_self ()
call expr%fac_scale%setup_expr (expr%var_list)
expr%has_fac_scale = .true.
end if
end subroutine parton_expr_setup_fac_scale
subroutine parton_expr_setup_ren_scale (expr, ef_ren_scale)
class(parton_expr_t), intent(inout), target :: expr
class(expr_factory_t), intent(in) :: ef_ren_scale
call ef_ren_scale%build (expr%ren_scale)
if (allocated (expr%ren_scale)) then
call expr%setup_var_self ()
call expr%ren_scale%setup_expr (expr%var_list)
expr%has_ren_scale = .true.
end if
end subroutine parton_expr_setup_ren_scale
@ %def parton_expr_setup_scale
@ %def parton_expr_setup_fac_scale
@ %def parton_expr_setup_ren_scale
@ Compile the weight expression.
<<Subevt expr: parton expr: TBP>>=
procedure :: setup_weight => parton_expr_setup_weight
<<Subevt expr: procedures>>=
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: procedures>>=
subroutine parton_expr_setup_subevt (expr, int, &
i_beam, i_in, i_out, f_beam, f_in, f_out)
class(parton_expr_t), intent(inout) :: expr
type(interaction_t), intent(in), target :: int
integer, dimension(:), intent(in) :: i_beam, i_in, i_out
type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
allocate (expr%i_beam (size (i_beam)))
allocate (expr%i_in (size (i_in)))
allocate (expr%i_out (size (i_out)))
expr%i_beam = i_beam
expr%i_in = i_in
expr%i_out = i_out
call interaction_to_subevt (int, &
expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t)
call subevt_set_pdg_beam (expr%subevt_t, f_beam%get_pdg ())
call subevt_set_pdg_incoming (expr%subevt_t, f_in%get_pdg ())
call subevt_set_pdg_outgoing (expr%subevt_t, f_out%get_pdg ())
call subevt_set_p2_beam (expr%subevt_t, f_beam%get_mass () ** 2)
call subevt_set_p2_incoming (expr%subevt_t, f_in%get_mass () ** 2)
call subevt_set_p2_outgoing (expr%subevt_t, f_out%get_mass () ** 2)
expr%n_in = size (i_in)
expr%n_out = size (i_out)
expr%n_tot = expr%n_in + expr%n_out
end subroutine parton_expr_setup_subevt
@ %def parton_expr_setup_subevt
@ Transfer PDG codes, masses (initalization) and momenta to a
predefined subevent. We use the flavor assignment of the first
branch in the interaction state matrix. Only incoming and outgoing
particles are transferred. Switch momentum sign for incoming
particles.
<<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: 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 (subevt, i, &
flv(j)%get_pdg (), &
vector4_null, &
flv(j)%get_mass () ** 2)
end do
do i = 1, n_in
j = j_in(i)
call subevt_set_incoming (subevt, n_beam + i, &
flv(j)%get_pdg (), &
vector4_null, &
flv(j)%get_mass () ** 2)
end do
do i = 1, n_out
j = j_out(i)
call subevt_set_outgoing (subevt, n_beam + n_in + i, &
flv(j)%get_pdg (), &
vector4_null, &
flv(j)%get_mass () ** 2)
end do
end subroutine interaction_to_subevt
subroutine interaction_momenta_to_subevt_id (int, j_beam, j_in, j_out, subevt)
type(interaction_t), intent(in) :: int
integer, dimension(:), intent(in) :: j_beam, j_in, j_out
type(subevt_t), intent(inout) :: subevt
call subevt_set_p_beam (subevt, - int%get_momenta (j_beam))
call subevt_set_p_incoming (subevt, - int%get_momenta (j_in))
call subevt_set_p_outgoing (subevt, int%get_momenta (j_out))
end subroutine interaction_momenta_to_subevt_id
subroutine interaction_momenta_to_subevt_tr &
(int, j_beam, j_in, j_out, lt, subevt)
type(interaction_t), intent(in) :: int
integer, dimension(:), intent(in) :: j_beam, j_in, j_out
type(subevt_t), intent(inout) :: subevt
type(lorentz_transformation_t), intent(in) :: lt
call subevt_set_p_beam &
(subevt, - lt * int%get_momenta (j_beam))
call subevt_set_p_incoming &
(subevt, - lt * int%get_momenta (j_in))
call subevt_set_p_outgoing &
(subevt, lt * int%get_momenta (j_out))
end subroutine interaction_momenta_to_subevt_tr
@ %def interaction_momenta_to_subevt
@ The second part takes the momenta from the interaction object and thus
completes the subevt. The partonic energy can then be computed.
<<Subevt expr: parton expr: TBP>>=
procedure :: fill_subevt => parton_expr_fill_subevt
<<Subevt expr: procedures>>=
subroutine parton_expr_fill_subevt (expr, int)
class(parton_expr_t), intent(inout) :: expr
type(interaction_t), intent(in), target :: int
call interaction_momenta_to_subevt (int, &
expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t)
expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t)
expr%subevt_filled = .true.
end subroutine parton_expr_fill_subevt
@ %def parton_expr_fill_subevt
@ Evaluate, if the event passes the selection. For absent expressions we take
default values.
<<Subevt expr: parton expr: TBP>>=
procedure :: evaluate => parton_expr_evaluate
<<Subevt expr: procedures>>=
subroutine parton_expr_evaluate &
(expr, passed, scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation)
class(parton_expr_t), intent(inout) :: expr
logical, intent(out) :: passed
real(default), intent(out) :: scale
real(default), intent(out) :: fac_scale
real(default), intent(out) :: ren_scale
real(default), intent(out) :: weight
real(default), intent(in), allocatable, optional :: scale_forced
logical, intent(in), optional :: force_evaluation
logical :: force_scale, force_eval
force_scale = .false.; force_eval = .false.
if (present (scale_forced)) force_scale = allocated (scale_forced)
if (present (force_evaluation)) force_eval = force_evaluation
call expr%base_evaluate (passed)
if (passed .or. force_eval) then
if (force_scale) then
scale = scale_forced
else if (expr%has_scale) then
call expr%scale%evaluate ()
if (expr%scale%is_known ()) then
scale = expr%scale%get_real ()
else
call msg_error ("Evaluate scale expression: result undefined")
scale = zero
end if
else
scale = expr%sqrts_hat
end if
if (force_scale) then
fac_scale = scale_forced
else if (expr%has_fac_scale) then
call expr%fac_scale%evaluate ()
if (expr%fac_scale%is_known ()) then
fac_scale = expr%fac_scale%get_real ()
else
call msg_error ("Evaluate factorization scale expression: &
&result undefined")
fac_scale = zero
end if
else
fac_scale = scale
end if
if (force_scale) then
ren_scale = scale_forced
else if (expr%has_ren_scale) then
call expr%ren_scale%evaluate ()
if (expr%ren_scale%is_known ()) then
ren_scale = expr%ren_scale%get_real ()
else
call msg_error ("Evaluate renormalization scale expression: &
&result undefined")
ren_scale = zero
end if
else
ren_scale = scale
end if
if (expr%has_weight) then
call expr%weight%evaluate ()
if (expr%weight%is_known ()) then
weight = expr%weight%get_real ()
else
call msg_error ("Evaluate weight expression: result undefined")
weight = zero
end if
else
weight = one
end if
else
weight = zero
end if
end subroutine parton_expr_evaluate
@ %def parton_expr_evaluate
@ Return the beam/incoming parton indices.
<<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: procedures>>=
subroutine parton_expr_get_beam_index (expr, i_beam)
class(parton_expr_t), intent(in) :: expr
integer, dimension(:), intent(out) :: i_beam
i_beam = expr%i_beam
end subroutine parton_expr_get_beam_index
subroutine parton_expr_get_in_index (expr, i_in)
class(parton_expr_t), intent(in) :: expr
integer, dimension(:), intent(out) :: i_in
i_in = expr%i_in
end subroutine parton_expr_get_in_index
@ %def parton_expr_get_beam_index
@ %def parton_expr_get_in_index
@
\subsection{Implementation for full events}
This implementation contains the expressions that we can evaluate for the
full event. It also contains data that pertain to the event, suitable
for communication with external event formats. These data
simultaneously serve as pointer targets for the variable lists hidden
in the expressions (eval trees).
Squared matrix element and weight values: when reading events from
file, the [[ref]] value is the number in the file, while the [[prc]]
value is the number that we calculate from the momenta in the file,
possibly with different parameters. When generating events the first
time, or if we do not recalculate, the numbers should coincide.
Furthermore, the array of [[alt]] values is copied from an array of
alternative event records. These values should represent calculated
values.
<<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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine event_expr_setup_vars (expr, sqrts)
class(event_expr_t), intent(inout), target :: expr
real(default), intent(in) :: sqrts
call expr%base_setup_vars (sqrts)
call var_list_append_string_ptr (expr%var_list, &
var_str ("$process_id"), expr%id, &
is_known = expr%has_id, &
locked = .true., verbose = .false., intrinsic = .true.)
call var_list_append_int_ptr (expr%var_list, &
var_str ("process_num_id"), expr%num_id, &
is_known = expr%has_num_id, &
locked = .true., verbose = .false., intrinsic = .true.)
call var_list_append_real_ptr (expr%var_list, &
var_str ("sqme"), expr%sqme_prc, &
is_known = expr%has_sqme_prc, &
locked = .true., verbose = .false., intrinsic = .true.)
call var_list_append_real_ptr (expr%var_list, &
var_str ("sqme_ref"), expr%sqme_ref, &
is_known = expr%has_sqme_ref, &
locked = .true., verbose = .false., intrinsic = .true.)
call var_list_append_int_ptr (expr%var_list, &
var_str ("event_index"), expr%index, &
is_known = expr%has_index, &
locked = .true., verbose = .false., intrinsic = .true.)
call var_list_append_real_ptr (expr%var_list, &
var_str ("event_weight"), expr%weight_prc, &
is_known = expr%has_weight_prc, &
locked = .true., verbose = .false., intrinsic = .true.)
call var_list_append_real_ptr (expr%var_list, &
var_str ("event_weight_ref"), expr%weight_ref, &
is_known = expr%has_weight_ref, &
locked = .true., verbose = .false., intrinsic = .true.)
call var_list_append_real_ptr (expr%var_list, &
var_str ("event_excess"), expr%excess_prc, &
is_known = expr%has_excess_prc, &
locked = .true., verbose = .false., intrinsic = .true.)
end subroutine event_expr_setup_vars
@ %def event_expr_setup_vars
@ Compile the analysis expression. If the pointer is disassociated, there is
no expression.
<<Subevt expr: event expr: TBP>>=
procedure :: setup_analysis => event_expr_setup_analysis
<<Subevt expr: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine event_expr_set_process_id (expr, id)
class(event_expr_t), intent(inout) :: expr
type(string_t), intent(in) :: id
expr%id = id
expr%has_id = .true.
end subroutine event_expr_set_process_id
subroutine event_expr_set_process_num_id (expr, num_id)
class(event_expr_t), intent(inout) :: expr
integer, intent(in) :: num_id
expr%num_id = num_id
expr%has_num_id = .true.
end subroutine event_expr_set_process_num_id
@ %def event_expr_set_process_id
@ %def event_expr_set_process_num_id
@ Reset / set the data that pertain to a particular event. The event
index is reset unless explicitly told to keep it.
<<Subevt expr: event expr: TBP>>=
procedure :: reset_contents => event_expr_reset_contents
procedure :: set => event_expr_set
<<Subevt expr: procedures>>=
subroutine event_expr_reset_contents (expr)
class(event_expr_t), intent(inout) :: expr
call expr%base_reset_contents ()
expr%has_sqme_ref = .false.
expr%has_sqme_prc = .false.
expr%has_sqme_alt = .false.
expr%has_weight_ref = .false.
expr%has_weight_prc = .false.
expr%has_weight_alt = .false.
expr%has_excess_prc = .false.
end subroutine event_expr_reset_contents
subroutine event_expr_set (expr, &
weight_ref, weight_prc, weight_alt, &
excess_prc, &
sqme_ref, sqme_prc, sqme_alt)
class(event_expr_t), intent(inout) :: expr
real(default), intent(in), optional :: weight_ref, weight_prc
real(default), intent(in), optional :: excess_prc
real(default), intent(in), optional :: sqme_ref, sqme_prc
real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt
if (present (sqme_ref)) then
expr%has_sqme_ref = .true.
expr%sqme_ref = sqme_ref
end if
if (present (sqme_prc)) then
expr%has_sqme_prc = .true.
expr%sqme_prc = sqme_prc
end if
if (present (sqme_alt)) then
expr%has_sqme_alt = .true.
expr%sqme_alt = sqme_alt
end if
if (present (weight_ref)) then
expr%has_weight_ref = .true.
expr%weight_ref = weight_ref
end if
if (present (weight_prc)) then
expr%has_weight_prc = .true.
expr%weight_prc = weight_prc
end if
if (present (weight_alt)) then
expr%has_weight_alt = .true.
expr%weight_alt = weight_alt
end if
if (present (excess_prc)) then
expr%has_excess_prc = .true.
expr%excess_prc = excess_prc
end if
end subroutine event_expr_set
@ %def event_expr_reset_contents event_expr_set
@ Access the subevent index.
<<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: procedures>>=
function event_expr_has_event_index (expr) result (flag)
class(event_expr_t), intent(in) :: expr
logical :: flag
flag = expr%has_index
end function event_expr_has_event_index
function event_expr_get_event_index (expr) result (index)
class(event_expr_t), intent(in) :: expr
integer :: index
if (expr%has_index) then
index = expr%index
else
index = 0
end if
end function event_expr_get_event_index
@ %def event_expr_has_event_index
@ %def event_expr_get_event_index
@ Set/increment the subevent index. Initialize it if necessary.
<<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: procedures>>=
subroutine event_expr_set_event_index (expr, index)
class(event_expr_t), intent(inout) :: expr
integer, intent(in) :: index
expr%index = index
expr%has_index = .true.
end subroutine event_expr_set_event_index
subroutine event_expr_reset_event_index (expr)
class(event_expr_t), intent(inout) :: expr
expr%has_index = .false.
end subroutine event_expr_reset_event_index
subroutine event_expr_increment_event_index (expr, offset)
class(event_expr_t), intent(inout) :: expr
integer, intent(in), optional :: offset
if (expr%has_index) then
expr%index = expr%index + 1
else if (present (offset)) then
call expr%set_event_index (offset + 1)
else
call expr%set_event_index (1)
end if
end subroutine event_expr_increment_event_index
@ %def event_expr_set_event_index
@ %def event_expr_increment_event_index
@ Fill the event expression: take the particle data and kinematics
from a [[particle_set]] object.
We allow the particle content to change for each event. Therefore, we set the
event variables each time.
Also increment the event index; initialize it if necessary.
<<Subevt expr: event expr: TBP>>=
procedure :: fill_subevt => event_expr_fill_subevt
<<Subevt expr: procedures>>=
subroutine event_expr_fill_subevt (expr, particle_set)
class(event_expr_t), intent(inout) :: expr
type(particle_set_t), intent(in) :: particle_set
call particle_set%to_subevt (expr%subevt_t, expr%colorize_subevt)
expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t)
expr%n_in = subevt_get_n_in (expr%subevt_t)
expr%n_out = subevt_get_n_out (expr%subevt_t)
expr%n_tot = expr%n_in + expr%n_out
expr%subevt_filled = .true.
end subroutine event_expr_fill_subevt
@ %def event_expr_fill_subevt
@ Evaluate, if the event passes the selection. For absent expressions we take
default values.
<<Subevt expr: event expr: TBP>>=
procedure :: evaluate => event_expr_evaluate
<<Subevt expr: procedures>>=
subroutine event_expr_evaluate (expr, passed, reweight, analysis_flag)
class(event_expr_t), intent(inout) :: expr
logical, intent(out) :: passed
real(default), intent(out) :: reweight
logical, intent(out) :: analysis_flag
call expr%base_evaluate (passed)
if (passed) then
if (expr%has_reweight) then
call expr%reweight%evaluate ()
if (expr%reweight%is_known ()) then
reweight = expr%reweight%get_real ()
else
call msg_error ("Evaluate reweight expression: &
&result undefined")
reweight = 0
end if
else
reweight = 1
end if
if (expr%has_analysis) then
call expr%analysis%evaluate ()
if (expr%analysis%is_known ()) then
analysis_flag = expr%analysis%get_log ()
else
call msg_error ("Evaluate analysis expression: &
&result undefined")
analysis_flag = .false.
end if
else
analysis_flag = .true.
end if
end if
end subroutine event_expr_evaluate
@ %def event_expr_evaluate
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Parton states}
A [[parton_state_t]] object contains the effective kinematics and
dynamics of an elementary partonic interaction, with or without the
beam/structure function state included. The type is abstract and has
two distinct extensions. The [[isolated_state_t]] extension describes
the isolated elementary interaction where the [[int_eff]] subobject
contains the complex transition amplitude, exclusive in all quantum
numbers. The particle content and kinematics describe the effective
partonic state. The [[connected_state_t]] extension contains the
partonic [[subevt]] and the expressions for cuts and scales which use
it.
In the isolated state, the effective partonic interaction may either
be identical to the hard interaction, in which case it is just a
pointer to the latter. Or it may involve a rearrangement of partons,
in which case we allocate it explicitly and flag this by
[[int_is_allocated]].
The [[trace]] evaluator contains the absolute square of the effective
transition amplitude matrix, summed over final states. It is also summed over
initial states, depending on the the beam setup allows. The result is used for
integration.
The [[matrix]] evaluator is the counterpart of [[trace]] which is kept
exclusive in all observable quantum numbers. The [[flows]] evaluator is
furthermore exclusive in colors, but neglecting all color interference. The
[[matrix]] and [[flows]] evaluators are filled only for sampling points that
become part of physical events.
Note: It would be natural to make the evaluators allocatable.
However, this causes memory corruption in gfortran 4.6.3. The extra
[[has_XXX]] flags indicate whether evaluators are active, instead.
This module contains no unit tests. The tests are covered by the
[[processes]] module below.
<<[[parton_states.f90]]>>=
<<File header>>
module parton_states
<<Use kinds>>
<<Use debug>>
use io_units
use format_utils, only: write_separator
use diagnostics
use lorentz
use subevents
use variables
use expr_base
use model_data
use flavors
use helicities
use colors
use quantum_numbers
use state_matrices
use polarizations
use interactions
use evaluators
use beams
use sf_base
use process_constants
use prc_core
use subevt_expr
<<Standard module head>>
<<Parton states: public>>
<<Parton states: types>>
contains
<<Parton states: procedures>>
end module parton_states
@ %def parton_states
@
\subsection{Abstract base type}
The common part are the evaluators, one for the trace (summed over all
quantum numbers), one for the transition matrix (summed only over
unobservable quantum numbers), and one for the flow distribution
(transition matrix without interferences, exclusive in color flow).
<<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
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine isolated_state_setup_square_trace (state, core, &
qn_mask_in, col, keep_fs_flavor)
class(isolated_state_t), intent(inout), target :: state
class(prc_core_t), intent(in) :: core
type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in
!!! Actually need allocatable attribute here fore once because col might
!!! enter the subroutine non-allocated.
integer, intent(in), dimension(:), allocatable :: col
logical, intent(in) :: keep_fs_flavor
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
associate (data => core%data)
allocate (qn_mask (data%n_in + data%n_out))
qn_mask( : data%n_in) = &
quantum_numbers_mask (.false., .true., .false.) &
.or. qn_mask_in
qn_mask(data%n_in + 1 : ) = &
quantum_numbers_mask (.not. keep_fs_flavor, .true., .true.)
if (core%use_color_factors) then
call state%trace%init_square (state%int_eff, qn_mask, &
col_flow_index = data%cf_index, &
col_factor = data%color_factors, &
col_index_hi = col, &
nc = core%nc)
else
call state%trace%init_square (state%int_eff, qn_mask, nc = core%nc)
end if
end associate
state%has_trace = .true.
end subroutine isolated_state_setup_square_trace
@ %def isolated_state_setup_square_trace
@ Setup an identity-evaluator for the trace. This implies that [[me]]
is considered to be a squared amplitude, as for example for BLHA matrix
elements.
<<Parton states: isolated state: TBP>>=
procedure :: setup_identity_trace => isolated_state_setup_identity_trace
<<Parton states: procedures>>=
subroutine isolated_state_setup_identity_trace (state, core, qn_mask_in, &
keep_fs_flavors, keep_colors)
class(isolated_state_t), intent(inout), target :: state
class(prc_core_t), intent(in) :: core
type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in
logical, intent(in), optional :: keep_fs_flavors, keep_colors
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
logical :: fs_flv_flag, col_flag
fs_flv_flag = .true.; col_flag = .true.
if (present(keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors
if (present(keep_colors)) col_flag = .not. keep_colors
associate (data => core%data)
allocate (qn_mask (data%n_in + data%n_out))
qn_mask( : data%n_in) = &
quantum_numbers_mask (.false., col_flag, .false.) .or. qn_mask_in
qn_mask(data%n_in + 1 : ) = &
quantum_numbers_mask (fs_flv_flag, col_flag, .true.)
end associate
call state%int_eff%set_mask (qn_mask)
call state%trace%init_identity (state%int_eff)
state%has_trace = .true.
end subroutine isolated_state_setup_identity_trace
@ %def isolated_state_setup_identity_trace
@ Setup the evaluator for the transition matrix, exclusive in
helicities where this is requested.
For all unstable final-state particles we keep polarization according to the
applicable decay options. If the process is a decay itself, this applies also
to the initial state.
For all polarized final-state particles, we keep polarization including
off-diagonal entries. We drop helicity completely for unpolarized final-state
particles.
For the initial state, if the particle has not been handled yet, we
apply the provided [[qn_mask_in]] which communicates the beam properties.
<<Parton states: isolated state: TBP>>=
procedure :: setup_square_matrix => isolated_state_setup_square_matrix
<<Parton states: procedures>>=
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: procedures>>=
subroutine isolated_state_setup_square_flows (state, core, model, qn_mask_in)
class(isolated_state_t), intent(inout), target :: state
class(prc_core_t), intent(in) :: core
class(model_data_t), intent(in), target :: model
type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
type(flavor_t), dimension(:), allocatable :: flv
integer :: i
logical :: helmask, helmask_hd
associate (data => core%data)
allocate (qn_mask (data%n_in + data%n_out))
allocate (flv (data%n_flv))
do i = 1, data%n_in + data%n_out
call flv%init (data%flv_state(i,:), model)
if ((data%n_in == 1 .or. i > data%n_in) &
.and. any (.not. flv%is_stable ())) then
helmask = all (flv%decays_isotropically ())
helmask_hd = all (flv%decays_diagonal ())
qn_mask(i) = quantum_numbers_mask (.false., .false., helmask, &
mask_hd = helmask_hd)
else if (i > data%n_in) then
helmask = all (.not. flv%is_polarized ())
qn_mask(i) = quantum_numbers_mask (.false., .false., helmask)
else
qn_mask(i) = quantum_numbers_mask (.false., .false., .false.) &
.or. qn_mask_in(i)
end if
end do
call state%flows%init_square (state%int_eff, qn_mask, &
expand_color_flows = .true.)
end associate
state%has_flows = .true.
end subroutine isolated_state_setup_square_flows
@ %def isolated_state_setup_square_flows
@
\subsection{Evaluator initialization: connected state}
Setup a trace evaluator as a product of two evaluators (incoming state,
effective interaction). In the result, all quantum numbers are summed over.
If the optional [[int]] interaction is provided, use this for the
first factor in the convolution. Otherwise, use the final interaction
of the stored [[sf_chain]].
The [[resonant]] flag applies if we want to construct
a decay chain. The resonance property can propagate to the final
event output.
<<Parton states: connected state: TBP>>=
procedure :: setup_connected_trace => connected_state_setup_connected_trace
<<Parton states: procedures>>=
subroutine connected_state_setup_connected_trace &
(state, isolated, int, resonant, undo_helicities, &
keep_fs_flavors, extended_sf)
class(connected_state_t), intent(inout), target :: state
type(isolated_state_t), intent(in), target :: isolated
type(interaction_t), intent(in), optional, target :: int
logical, intent(in), optional :: resonant
logical, intent(in), optional :: undo_helicities
logical, intent(in), optional :: keep_fs_flavors
logical, intent(in), optional :: extended_sf
type(quantum_numbers_mask_t) :: mask
type(interaction_t), pointer :: src_int, beam_int
logical :: reduce, fs_flv_flag
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 = extended_sf)
if (reduce) then
beam_int => isolated%sf_chain_eff%get_beam_int_ptr ()
call undo_qn_hel (beam_int, mask, beam_int%get_n_tot ())
call undo_qn_hel (src_int, mask, src_int%get_n_tot ())
call beam_int%set_matrix_element (cmplx (1, 0, default))
call src_int%set_matrix_element (cmplx (1, 0, default))
end if
state%has_trace = .true.
contains
subroutine undo_qn_hel (int_in, mask, n_tot)
type(interaction_t), intent(inout) :: int_in
type(quantum_numbers_mask_t), intent(in) :: mask
integer, intent(in) :: n_tot
type(quantum_numbers_mask_t), dimension(n_tot) :: mask_in
mask_in = mask
call int_in%set_mask (mask_in)
end subroutine undo_qn_hel
end subroutine connected_state_setup_connected_trace
@ %def connected_state_setup_connected_trace
@ Setup a matrix evaluator as a product of two evaluators (incoming
state, effective interation). In the intermediate state, color and
helicity is summed over. In the final state, we keep the quantum
numbers which are present in the original evaluators.
<<Parton states: connected state: TBP>>=
procedure :: setup_connected_matrix => connected_state_setup_connected_matrix
<<Parton states: procedures>>=
subroutine connected_state_setup_connected_matrix &
(state, isolated, int, resonant, qn_filter_conn)
class(connected_state_t), intent(inout), target :: state
type(isolated_state_t), intent(in), target :: isolated
type(interaction_t), intent(in), optional, target :: int
logical, intent(in), optional :: resonant
type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
type(quantum_numbers_mask_t) :: mask
type(interaction_t), pointer :: src_int
mask = quantum_numbers_mask (.false., .true., .true.)
if (present (int)) then
src_int => int
else
src_int => isolated%sf_chain_eff%get_out_int_ptr ()
end if
call state%matrix%init_product &
(src_int, isolated%matrix, mask, &
qn_filter_conn = qn_filter_conn, &
connections_are_resonant = resonant)
state%has_matrix = .true.
end subroutine connected_state_setup_connected_matrix
@ %def connected_state_setup_connected_matrix
@ Setup a matrix evaluator as a product of two evaluators (incoming
state, effective interation). In the intermediate state, only
helicity is summed over. In the final state, we keep the quantum
numbers which are present in the original evaluators.
If the optional [[int]] interaction is provided, use this for the
first factor in the convolution. Otherwise, use the final interaction
of the stored [[sf_chain]], after creating an intermediate interaction
that includes a correlated color state. We assume that for a
caller-provided [[int]], this is not necessary.
<<Parton states: connected state: TBP>>=
procedure :: setup_connected_flows => connected_state_setup_connected_flows
<<Parton states: procedures>>=
subroutine connected_state_setup_connected_flows &
(state, isolated, int, resonant, qn_filter_conn)
class(connected_state_t), intent(inout), target :: state
type(isolated_state_t), intent(in), target :: isolated
type(interaction_t), intent(in), optional, target :: int
logical, intent(in), optional :: resonant
type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
type(quantum_numbers_mask_t) :: mask
type(interaction_t), pointer :: src_int
mask = quantum_numbers_mask (.false., .false., .true.)
if (present (int)) then
src_int => int
else
src_int => isolated%sf_chain_eff%get_out_int_ptr ()
call state%flows_sf%init_color_contractions (src_int)
state%has_flows_sf = .true.
src_int => state%flows_sf%interaction_t
end if
call state%flows%init_product (src_int, isolated%flows, mask, &
qn_filter_conn = qn_filter_conn, &
connections_are_resonant = resonant)
state%has_flows = .true.
end subroutine connected_state_setup_connected_flows
@ %def connected_state_setup_connected_flows
@ Determine and store the flavor content for the connected state.
This queries the [[matrix]] evaluator component, which should hold the
requested flavor information.
<<Parton states: connected state: TBP>>=
procedure :: setup_state_flv => connected_state_setup_state_flv
<<Parton states: procedures>>=
subroutine connected_state_setup_state_flv (state, n_out_hard)
class(connected_state_t), intent(inout), target :: state
integer, intent(in) :: n_out_hard
call interaction_get_flv_content &
(state%matrix%interaction_t, state%state_flv, n_out_hard)
end subroutine connected_state_setup_state_flv
@ %def connected_state_setup_state_flv
@ Return the current flavor state object.
<<Parton states: connected state: TBP>>=
procedure :: get_state_flv => connected_state_get_state_flv
<<Parton states: procedures>>=
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: procedures>>=
subroutine connected_state_setup_subevt (state, sf_chain, f_beam, f_in, f_out)
class(connected_state_t), intent(inout), target :: state
type(sf_chain_instance_t), intent(in), target :: sf_chain
type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
integer :: n_beam, n_in, n_out, n_vir, n_tot, i, j
integer, dimension(:), allocatable :: i_beam, i_in, i_out
integer :: sf_out_i
type(interaction_t), pointer :: sf_int
sf_int => sf_chain%get_out_int_ptr ()
n_beam = size (f_beam)
n_in = size (f_in)
n_out = size (f_out)
n_vir = state%trace%get_n_vir ()
n_tot = state%trace%get_n_tot ()
allocate (i_beam (n_beam), i_in (n_in), i_out (n_out))
i_beam = [(i, i = 1, n_beam)]
do j = 1, n_in
sf_out_i = sf_chain%get_out_i (j)
i_in(j) = interaction_find_link &
(state%trace%interaction_t, sf_int, sf_out_i)
end do
i_out = [(i, i = n_vir + 1, n_tot)]
call state%expr%setup_subevt (state%trace%interaction_t, &
i_beam, i_in, i_out, f_beam, f_in, f_out)
state%has_expr = .true.
end subroutine connected_state_setup_subevt
@ %def connected_state_setup_subevt
@ Initialize the variable list specific for this state/term. We insert event
variables ([[sqrts_hat]]) and link the process variable list. The variable
list acquires pointers to subobjects of [[state]], which must therefore have a
[[target]] attribute.
<<Parton states: connected state: TBP>>=
procedure :: setup_var_list => connected_state_setup_var_list
<<Parton states: procedures>>=
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: procedures>>=
subroutine connected_state_setup_cuts (state, ef_cuts)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_cuts
call state%expr%setup_selection (ef_cuts)
end subroutine connected_state_setup_cuts
subroutine connected_state_setup_scale (state, ef_scale)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_scale
call state%expr%setup_scale (ef_scale)
end subroutine connected_state_setup_scale
subroutine connected_state_setup_fac_scale (state, ef_fac_scale)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_fac_scale
call state%expr%setup_fac_scale (ef_fac_scale)
end subroutine connected_state_setup_fac_scale
subroutine connected_state_setup_ren_scale (state, ef_ren_scale)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_ren_scale
call state%expr%setup_ren_scale (ef_ren_scale)
end subroutine connected_state_setup_ren_scale
subroutine connected_state_setup_weight (state, ef_weight)
class(connected_state_t), intent(inout), target :: state
class(expr_factory_t), intent(in) :: ef_weight
call state%expr%setup_weight (ef_weight)
end subroutine connected_state_setup_weight
@ %def connected_state_setup_expressions
@ Reset the expression object: invalidate the subevt.
<<Parton states: connected state: TBP>>=
procedure :: reset_expressions => connected_state_reset_expressions
<<Parton states: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine parton_state_send_kinematics (state)
class(parton_state_t), intent(inout), target :: state
if (state%has_trace) then
call interaction_send_momenta (state%trace%interaction_t)
select type (state)
class is (connected_state_t)
call state%expr%fill_subevt (state%trace%interaction_t)
end select
end if
end subroutine parton_state_send_kinematics
@ %def parton_state_send_kinematics
@ Evaluate the expressions. The routine evaluates first the cut expression.
If the event passes, it evaluates the other expressions. Where no expressions
are defined, default values are inserted.
<<Parton states: connected state: TBP>>=
procedure :: evaluate_expressions => connected_state_evaluate_expressions
<<Parton states: procedures>>=
subroutine connected_state_evaluate_expressions (state, passed, &
scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation)
class(connected_state_t), intent(inout) :: state
logical, intent(out) :: passed
real(default), intent(out) :: scale, fac_scale, ren_scale, weight
real(default), intent(in), allocatable, optional :: scale_forced
logical, intent(in), optional :: force_evaluation
if (state%has_expr) then
call state%expr%evaluate (passed, scale, fac_scale, ren_scale, weight, &
scale_forced, force_evaluation)
end if
end subroutine connected_state_evaluate_expressions
@ %def connected_state_evaluate_expressions
@ Evaluate the structure-function chain, if it is allocated
explicitly. The argument is the factorization scale.
If the chain is merely a pointer, the chain should already be
evaluated at this point.
<<Parton states: isolated state: TBP>>=
procedure :: evaluate_sf_chain => isolated_state_evaluate_sf_chain
<<Parton states: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
function parton_state_get_trace_int_ptr (state) result (ptr)
class(parton_state_t), intent(in), target :: state
type(interaction_t), pointer :: ptr
if (state%has_trace) then
ptr => state%trace%interaction_t
else
ptr => null ()
end if
end function parton_state_get_trace_int_ptr
function parton_state_get_matrix_int_ptr (state) result (ptr)
class(parton_state_t), intent(in), target :: state
type(interaction_t), pointer :: ptr
if (state%has_matrix) then
ptr => state%matrix%interaction_t
else
ptr => null ()
end if
end function parton_state_get_matrix_int_ptr
function parton_state_get_flows_int_ptr (state) result (ptr)
class(parton_state_t), intent(in), target :: state
type(interaction_t), pointer :: ptr
if (state%has_flows) then
ptr => state%flows%interaction_t
else
ptr => null ()
end if
end function parton_state_get_flows_int_ptr
@ %def parton_state_get_trace_int_ptr
@ %def parton_state_get_matrix_int_ptr
@ %def parton_state_get_flows_int_ptr
@ Return the indices of the beam particles and the outgoing particles within
the trace (and thus, matrix and flows) evaluator, respectively.
<<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: procedures>>=
subroutine connected_state_get_beam_index (state, i_beam)
class(connected_state_t), intent(in) :: state
integer, dimension(:), intent(out) :: i_beam
call state%expr%get_beam_index (i_beam)
end subroutine connected_state_get_beam_index
subroutine connected_state_get_in_index (state, i_in)
class(connected_state_t), intent(in) :: state
integer, dimension(:), intent(out) :: i_in
call state%expr%get_in_index (i_in)
end subroutine connected_state_get_in_index
@ %def connected_state_get_beam_index
@ %def connected_state_get_in_index
@
<<Parton states: public>>=
public :: refill_evaluator
<<Parton states: procedures>>=
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: procedures>>=
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
!!! Don't forget the color factor
me_check_tot = 3._default * me_check_tot
me_check_1 = 3._default * me_check_1
me_check_2 = 3._default * me_check_2
write (u, "(A)")
write (u, "(A)") "* Setup interaction"
call int%basic_init (2, 0, 2, set_relations = .true.)
call int%set_state_matrix (state)
core%data%n_in = 2; core%data%n_out = 2
core%data%n_flv = 2
allocate (core%data%flv_state (4, 2))
core%data%flv_state (1, :) = [11, 11]
core%data%flv_state (2, :) = [-11, -11]
core%data%flv_state (3, :) = [1, 2]
core%data%flv_state (4, :) = [-1, -2]
core%use_color_factors = .false.
core%nc = 3
write (u, "(A)") "* Init isolated state"
call isolated_state%init (sf_chain, int)
!!! There is only one color flow.
allocate (col_flow_index (n_states)); col_flow_index = 1
call qn_mask%init (.false., .false., .true., mask_cg = .false.)
write (u, "(A)") "* Give a trace to the isolated state"
call isolated_state%setup_square_trace (core, qn_mask, col_flow_index, .false.)
call isolated_state%evaluate_trace ()
write (u, "(A)")
write (u, "(A)", advance = "no") "* Squared matrix element correct: "
write (u, "(L1)") nearly_equal (me_check_tot, &
isolated_state%trace%get_matrix_element (1), rel_smallness = 0.00001_default)
write (u, "(A)") "* Give a matrix to the isolated state"
call create_test_model (var_str ("SM"), test_model)
call isolated_state%setup_square_matrix (core, test_model, qn_mask, col_flow_index)
call isolated_state%evaluate_matrix ()
write (u, "(A)") "* Sub-matrixelements correct: "
tmp1 = nearly_equal (me_check_1, &
isolated_state%matrix%get_matrix_element (1), rel_smallness = 0.00001_default)
tmp2 = nearly_equal (me_check_2, &
isolated_state%matrix%get_matrix_element (2), rel_smallness = 0.00001_default)
write (u, "(A,L1,A,L1)") "* 1: ", tmp1, ", 2: ", tmp2
write (u, "(A)") "* Test output end: parton_states_1"
end subroutine parton_states_1
@ %def parton_states_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Process component management}
This module contains tools for managing and combining process
components and matrix-element code and values, acting at a level below
the actual process definition.
\subsection{Abstract base type}
The types introduced here are abstract base types.
<<[[pcm_base.f90]]>>=
<<File header>>
module pcm_base
<<Use kinds>>
use io_units
use diagnostics
use format_utils, only: write_integer_array
use format_utils, only: write_separator
use physics_defs, only: BORN, NLO_REAL
<<Use strings>>
use os_interface, only: os_data_t
use process_libraries, only: process_component_def_t
use process_libraries, only: process_library_t
use prc_core_def
use prc_core
use variables, only: var_list_t
use mappings, only: mapping_defaults_t
use phs_base, only: phs_config_t
use phs_forests, only: phs_parameters_t
use mci_base, only: mci_t
use model_data, only: model_data_t
use models, only: model_t
use blha_config, only: blha_master_t
use blha_olp_interfaces, only: blha_template_t
use process_config
use process_mci, only: process_mci_entry_t
<<Standard module head>>
<<PCM base: public>>
<<PCM base: parameters>>
<<PCM base: types>>
<<PCM base: interfaces>>
contains
<<PCM base: procedures>>
end module pcm_base
@ %def pcm_base
@
\subsection{Core management}
This object holds information about the cores used by the components
and allocates the corresponding manager instance.
[[i_component]] is the index of the process component which this core belongs
to. The pointer to the core definition is a convenient help in configuring
the core itself.
We allow for a [[blha_config]] configuration object that covers BLHA cores.
The BLHA standard is suitable generic to warrant support outside of specific
type extension (i.e., applies to LO and NLO if requested). The BLHA
configuration is allocated only if the core requires it.
<<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: procedures>>=
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: procedures>>=
subroutine core_entry_configure (core_entry, lib, id)
class(core_entry_t), intent(inout) :: core_entry
type(process_library_t), intent(in), target :: lib
type(string_t), intent(in) :: id
call core_entry%core%init &
(core_entry%core_def, lib, id, core_entry%i_component)
end subroutine core_entry_configure
@ %def core_entry_configure
@
\subsection{Process component manager}
This object may hold process and method-specific data, and it should
allocate the corresponding manager instance.
The number of components determines the [[component_selected]] array.
[[i_phs_config]] is a lookup table that returns the PHS configuration index
for a given component index.
[[i_core]] is a lookup table that returns the core-entry index for a given
component index.
<<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_instance), deferred :: allocate_instance
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_allocate_instance (pcm, instance)
import
class(pcm_t), intent(in) :: pcm
class(pcm_instance_t), intent(inout), allocatable :: instance
end subroutine pcm_allocate_instance
end interface
@ %def pcm_allocate_instance
@
<<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: procedures>>=
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(in) :: pcm
type(blha_master_t), intent(inout) :: blha_master
type(var_list_t), intent(in) :: var_list
end subroutine pcm_set_blha_methods
end interface
@ %def pcm_set_blha_methods
@ Produce the LO and NLO flavor-state tables (as far as available), as
appropriate for BLHA configuration. We may inspect either the PCM itself or
the array of process cores.
<<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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine pcm_record_inactive_components (pcm, component, meta)
class(pcm_t), intent(inout) :: pcm
type(process_component_t), dimension(:), intent(in) :: component
type(process_metadata_t), intent(inout) :: meta
integer :: i
pcm%component_active = component%active
do i = 1, pcm%n_components
if (.not. component(i)%active) call meta%deactivate_component (i)
end do
end subroutine pcm_record_inactive_components
@ %def pcm_record_inactive_components
@
\subsection{Manager instance}
This object deals with the actual (squared) matrix element values.
<<PCM base: public>>=
public :: pcm_instance_t
<<PCM base: types>>=
type, abstract :: pcm_instance_t
class(pcm_t), pointer :: config => null ()
logical :: bad_point = .false.
contains
<<PCM base: pcm instance: TBP>>
end type pcm_instance_t
@ %def pcm_instance_t
@
<<PCM base: pcm instance: TBP>>=
procedure(pcm_instance_final), deferred :: final
<<PCM base: interfaces>>=
abstract interface
subroutine pcm_instance_final (pcm_instance)
import
class(pcm_instance_t), intent(inout) :: pcm_instance
end subroutine pcm_instance_final
end interface
@ %def pcm_instance_final
@
<<PCM base: pcm instance: TBP>>=
procedure :: link_config => pcm_instance_link_config
<<PCM base: procedures>>=
subroutine pcm_instance_link_config (pcm_instance, config)
class(pcm_instance_t), intent(inout) :: pcm_instance
class(pcm_t), intent(in), target :: config
pcm_instance%config => config
end subroutine pcm_instance_link_config
@ %def pcm_instance_link_config
@
<<PCM base: pcm instance: TBP>>=
procedure :: is_valid => pcm_instance_is_valid
<<PCM base: procedures>>=
function pcm_instance_is_valid (pcm_instance) result (valid)
logical :: valid
class(pcm_instance_t), intent(in) :: pcm_instance
valid = .not. pcm_instance%bad_point
end function pcm_instance_is_valid
@ %def pcm_instance_is_valid
@
<<PCM base: pcm instance: TBP>>=
procedure :: set_bad_point => pcm_instance_set_bad_point
<<PCM base: procedures>>=
pure subroutine pcm_instance_set_bad_point (pcm_instance, bad_point)
class(pcm_instance_t), intent(inout) :: pcm_instance
logical, intent(in) :: bad_point
pcm_instance%bad_point = pcm_instance%bad_point .or. bad_point
end subroutine pcm_instance_set_bad_point
@ %def pcm_instance_set_bad_point
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{The process object}
<<[[process.f90]]>>=
<<File header>>
module process
<<Use kinds>>
<<Use strings>>
<<Use debug>>
use io_units
use format_utils, only: write_separator
use constants
use diagnostics
use numeric_utils
use lorentz
use cputime
use md5
use rng_base
use dispatch_rng, only: dispatch_rng_factory
use dispatch_rng, only: update_rng_seed_in_var_list
use os_interface
use sm_qcd
use integration_results
use mci_base
use flavors
use model_data
use models
use physics_defs
use process_libraries
use process_constants
use particles
use variables
use beam_structures
use beams
use interactions
use pdg_arrays
use expr_base
use sf_base
use sf_mappings
use resonances, only: resonance_history_t, resonance_history_set_t
use prc_test_core, only: test_t
use prc_core_def, only: prc_core_def_t
use prc_core, only: prc_core_t, helicity_selection_t
use prc_external, only: prc_external_t
use prc_recola, only: prc_recola_t
use blha_olp_interfaces, only: prc_blha_t, blha_template_t
use prc_threshold, only: prc_threshold_t
use phs_fks, only: phs_fks_config_t
use phs_base
use mappings, only: mapping_defaults_t
use phs_forests, only: phs_parameters_t
use phs_wood, only: phs_wood_config_t
use phs_wood, only: EXTENSION_DEFAULT, EXTENSION_DGLAP
use dispatch_phase_space, only: dispatch_phs
use blha_config, only: blha_master_t
use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES
use parton_states, only: connected_state_t
use pcm_base
use pcm
use process_counter
use process_config
use process_mci
<<Standard module head>>
<<Process: public>>
<<Process: public parameters>>
<<Process: types>>
<<Process: interfaces>>
contains
<<Process: procedures>>
end module process
@ %def process
@
\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}
A process object is the workspace for the process instance.
After initialization, its contents are filled by
integration passes which shape the integration grids and compute cross
sections. Processes are set up initially from user-level
configuration data. After calculating integrals and thus developing
integration grid data, the program may use a process
object or a copy of it for the purpose of generating events.
The process object consists of several subobjects with their specific
purposes. The corresponding types are defined below. (Technically,
the subobject type definitions have to come before the process type
definition, but with NOWEB magic we reverse this order here.)
The [[type]] determines whether we are considering a decay or a
scattering process.
The [[meta]] object describes the process and its environment. All
contents become fixed when the object is initialized.
The [[config]] object holds physical and technical configuration data
that have been obtained during process initialization, and which are
common to all process components.
The individual process components are configured in the [[component]]
objects. These objects contain more configuration parameters and
workspace, as needed for the specific process variant.
The [[term]] objects describe parton configurations which are
technically used as phase-space points. Each process component may
split into several terms with distinct kinematics and particle
content. Furthermore, each term may project on a different physical
state, e.g., by particle recombination. The [[term]] object provides
the framework for this projection, for applying cuts, weight, and thus
completing the process calculation.
The [[beam_config]] object describes the incoming particles, either the
decay mother or the scattering beams. It also contains the structure-function
information.
The [[mci_entry]] objects configure a MC input parameter set and integrator,
each. The number of parameters depends on the process component and on the
beam and structure-function setup.
The [[pcm]] component is the process-component manager. This
polymorphic object manages and hides the details of dealing with NLO
processes where several components have to be combined in a
non-trivial way. It also acts as an abstract factory for the
corresponding object in [[process_instance]], which does the actual
work for this matter.
<<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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_final (process)
class(process_t), intent(inout) :: process
integer :: i
! call process%meta%final ()
call process%env%final ()
! call process%config%final ()
if (allocated (process%component)) then
do i = 1, size (process%component)
call process%component(i)%final ()
end do
end if
if (allocated (process%term)) then
do i = 1, size (process%term)
call process%term(i)%final ()
end do
end if
call process%beam_config%final ()
if (allocated (process%mci_entry)) then
do i = 1, size (process%mci_entry)
call process%mci_entry(i)%final ()
end do
end if
if (allocated (process%pcm)) then
call process%pcm%final ()
deallocate (process%pcm)
end if
end subroutine process_final
@ %def process_final
@
\subsubsection{Process setup}
Initialize a process. We need a process library [[lib]] and the process
identifier [[proc_id]] (string). We will fetch the current run ID from the
variable list [[var_list]].
We collect all important data from the environment and store them in the
appropriate places. OS data, model, and variable list are copied
into [[env]] (true snapshot), also the process library (pointer only).
The [[meta]] subobject is initialized with process ID and attributes taken
from the process library.
We initialize the [[config]] subobject with all data that are relevant for
this run, using the settings from [[env]]. These data determine the MD5 sum
for this run, which allows us to identify the setup and possibly skips in a
later re-run.
We also allocate and initialize the embedded RNG factory. We take the seed
from the [[var_list]], and we should return the [[var_list]] to the caller
with a new seed.
Finally, we allocate the process component manager [[pcm]], which implements
the chosen algorithm for process integration. The first task of the manager
is to allocate the component array and to determine the component categories
(e.g., Born/Virtual etc.).
TODO wk 2018: The [[pcm]] dispatcher should be provided by the caller, if we
eventually want to eliminate dependencies on concrete [[pcm_t]] extensions.
<<Process: process: TBP>>=
procedure :: init => process_init
<<Process: 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.
<<Process: 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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_prepare_blha_cores (process)
class(process_t), intent(inout), target :: process
integer :: i
associate (pcm => process%pcm)
do i = 1, size (process%core_entry)
associate (core_entry => process%core_entry(i))
if (core_entry%core%uses_blha ()) then
pcm%uses_blha = .true.
call pcm%prepare_blha_core (core_entry, process%config%model)
end if
end associate
end do
end associate
end subroutine process_prepare_blha_cores
@ %def process_prepare_blha_cores
@ Create the BLHA interface data, using PCM for specific data, and write the
BLHA contract file(s).
We take various configuration data and copy them to the [[blha_master]]
record, which then creates and writes the contracts.
For assigning the QCD/QED coupling powers, we inspect the first process
component only. The other parameters are taken as-is from the process
environment variables.
<<Process: process: TBP>>=
procedure :: create_blha_interface => process_create_blha_interface
<<Process: procedures>>=
subroutine process_create_blha_interface (process)
class(process_t), intent(in) :: process
integer :: alpha_power, alphas_power
integer :: openloops_phs_tolerance, openloops_stability_log
logical :: use_cms, use_collier
type(string_t) :: ew_scheme, correction_type
type(string_t) :: openloops_extra_cmd
type(blha_master_t) :: blha_master
integer, dimension(:,:), allocatable :: flv_born, flv_real
if (process%pcm%uses_blha) then
call collect_configuration_parameters (process%get_var_list_ptr ())
call process%component(1)%config%get_coupling_powers &
(alpha_power, alphas_power)
associate (pcm => process%pcm)
call pcm%set_blha_methods (blha_master, process%get_var_list_ptr ())
call blha_master%set_ew_scheme (ew_scheme)
call blha_master%allocate_config_files ()
call blha_master%set_correction_type (correction_type)
call blha_master%setup_additional_features ( &
openloops_phs_tolerance, &
use_cms, &
openloops_stability_log, &
use_collier, &
extra_cmd = openloops_extra_cmd, &
beam_structure = process%env%get_beam_structure ())
call pcm%get_blha_flv_states (process%core_entry, flv_born, flv_real)
call blha_master%generate (process%meta%id, &
process%config%model, process%config%n_in, &
alpha_power, alphas_power, &
flv_born, flv_real)
call blha_master%write_olp (process%meta%id)
end associate
end if
contains
subroutine collect_configuration_parameters (var_list)
type(var_list_t), intent(in) :: var_list
openloops_phs_tolerance = &
var_list%get_ival (var_str ("openloops_phs_tolerance"))
openloops_stability_log = &
var_list%get_ival (var_str ("openloops_stability_log"))
use_cms = &
var_list%get_lval (var_str ("?openloops_use_cms"))
use_collier = &
var_list%get_lval (var_str ("?openloops_use_collier"))
ew_scheme = &
var_list%get_sval (var_str ("$blha_ew_scheme"))
correction_type = &
var_list%get_sval (var_str ("$nlo_correction_type"))
openloops_extra_cmd = &
var_list%get_sval (var_str ("$openloops_extra_cmd"))
end subroutine collect_configuration_parameters
end subroutine process_create_blha_interface
@ %def process_create_blha_interface
@ Initialize the process components, one by one. We require templates for the
[[mci]] (integrator) and [[phs_config]] (phase-space) configuration data.
The [[active]] flag is set if the component has an associated matrix
element, so we can compute it. The case of no core is a unit-test case.
The specifics depend on the algorithm and are delegated to the [[pcm]]
process-component manager.
The optional [[phs_config]] overrides a pre-generated config array (for unit
test).
<<Process: process: TBP>>=
procedure :: init_components => process_init_components
<<Process: procedures>>=
subroutine process_init_components (process, phs_config)
class(process_t), intent(inout), target :: process
class(phs_config_t), allocatable, intent(in), optional :: phs_config
integer :: i, i_core
class(prc_core_t), pointer :: core
logical :: active
associate (pcm => process%pcm)
do i = 1, pcm%n_components
i_core = pcm%get_i_core(i)
if (i_core > 0) then
core => process%get_core_ptr (i_core)
active = core%has_matrix_element ()
else
active = .true.
end if
if (present (phs_config)) then
call pcm%init_component (process%component(i), &
i, &
active, &
phs_config, &
process%env, process%meta, process%config)
else
call pcm%init_component (process%component(i), &
i, &
active, &
process%phs_entry(pcm%i_phs_config(i))%phs_config, &
process%env, process%meta, process%config)
end if
end do
end associate
end subroutine process_init_components
@ %def process_init_components
@ If process components have turned out to be inactive, this has to be
recorded in the [[meta]] block. Delegate to the [[pcm]].
<<Process: process: TBP>>=
procedure :: record_inactive_components => process_record_inactive_components
<<Process: procedures>>=
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: procedures>>=
subroutine process_setup_terms (process, with_beams)
class(process_t), intent(inout), target :: process
logical, intent(in), optional :: with_beams
class(model_data_t), pointer :: model
integer :: i, j, k, i_term
integer, dimension(:), allocatable :: n_entry
integer :: n_components, n_tot
integer :: i_sub
type(string_t) :: subtraction_method
class(prc_core_t), pointer :: core => null ()
logical :: setup_subtraction_component, singular_real
logical :: requires_spin_correlations
integer :: nlo_type_to_fetch, n_emitters
i_sub = 0
model => process%config%model
n_components = process%meta%n_components
allocate (n_entry (n_components), source = 0)
do i = 1, n_components
associate (component => process%component(i))
if (component%active) then
n_entry(i) = 1
if (component%get_nlo_type () == NLO_REAL) then
select type (pcm => process%pcm)
type is (pcm_nlo_t)
if (component%component_type /= COMP_REAL_FIN) &
n_entry(i) = n_entry(i) + pcm%region_data%get_n_phs ()
end select
end if
end if
end associate
end do
n_tot = sum (n_entry)
allocate (process%term (n_tot))
k = 0
if (process%is_nlo_calculation ()) then
i_sub = process%component(1)%config%get_associated_subtraction ()
subtraction_method = process%component(i_sub)%config%get_me_method ()
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)
singular_real = component%get_nlo_type () == NLO_REAL &
.and. component%component_type /= COMP_REAL_FIN
setup_subtraction_component = singular_real .and. j == n_entry(i)
i_term = k + j
component%i_term(j) = i_term
if (singular_real) then
process%term(i_term)%i_sub = k + n_entry(i)
else
process%term(i_term)%i_sub = 0
end if
if (setup_subtraction_component) then
select type (pcm => process%pcm)
class is (pcm_nlo_t)
process%term(i_term)%i_core = pcm%i_core(pcm%i_sub)
end select
else
process%term(i_term)%i_core = process%pcm%get_i_core(i)
end if
if (process%term(i_term)%i_core == 0) then
call msg_bug ("Process '" // char (process%get_id ()) &
// "': core not found!")
end if
core => process%get_core_term (i_term)
if (i_sub > 0) then
select type (pcm => process%pcm)
type is (pcm_nlo_t)
requires_spin_correlations = &
pcm%region_data%requires_spin_correlations ()
- n_emitters = pcm%region_data%n_emitters
+ 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: procedures>>=
subroutine process_setup_beams_sqrts (process, sqrts, beam_structure, i_core)
class(process_t), intent(inout) :: process
real(default), intent(in) :: sqrts
type(beam_structure_t), intent(in), optional :: beam_structure
integer, intent(in), optional :: i_core
type(pdg_array_t), dimension(:,:), allocatable :: pdg_in
integer, dimension(2) :: pdg_scattering
type(flavor_t), dimension(2) :: flv_in
integer :: i, i0, ic
allocate (pdg_in (2, process%meta%n_components))
i0 = 0
do i = 1, process%meta%n_components
if (process%component(i)%active) then
if (present (i_core)) then
ic = i_core
else
ic = process%pcm%get_i_core (i)
end if
associate (core => process%core_entry(ic)%core)
pdg_in(:,i) = core%data%get_pdg_in ()
end associate
if (i0 == 0) i0 = i
end if
end do
do i = 1, process%meta%n_components
if (.not. process%component(i)%active) then
pdg_in(:,i) = pdg_in(:,i0)
end if
end do
if (all (pdg_array_get_length (pdg_in) == 1) .and. &
all (pdg_in(1,:) == pdg_in(1,i0)) .and. &
all (pdg_in(2,:) == pdg_in(2,i0))) then
pdg_scattering = pdg_array_get (pdg_in(:,i0), 1)
call flv_in%init (pdg_scattering, process%config%model)
call process%beam_config%init_scattering (flv_in, sqrts, beam_structure)
else
call msg_fatal ("Setting up process '" // char (process%meta%id) // "':", &
[var_str (" --------------------------------------------"), &
var_str ("Inconsistent initial state. This happens if either "), &
var_str ("several processes with non-matching initial states "), &
var_str ("have been added, or for a single process with an "), &
var_str ("initial state flavor sum. In that case, please set beams "), &
var_str ("explicitly [singling out a flavor / structure function.]")])
end if
end subroutine process_setup_beams_sqrts
@ %def process_setup_beams_sqrts
@ This is the version that applies to decay processes. The energy is the
particle mass, hence no extra argument.
<<Process: process: TBP>>=
procedure :: setup_beams_decay => process_setup_beams_decay
<<Process: procedures>>=
subroutine process_setup_beams_decay (process, rest_frame, beam_structure, i_core)
class(process_t), intent(inout), target :: process
logical, intent(in), optional :: rest_frame
type(beam_structure_t), intent(in), optional :: beam_structure
integer, intent(in), optional :: i_core
type(pdg_array_t), dimension(:,:), allocatable :: pdg_in
integer, dimension(1) :: pdg_decay
type(flavor_t), dimension(1) :: flv_in
integer :: i, i0, ic
allocate (pdg_in (1, process%meta%n_components))
i0 = 0
do i = 1, process%meta%n_components
if (process%component(i)%active) then
if (present (i_core)) then
ic = i_core
else
ic = process%pcm%get_i_core (i)
end if
associate (core => process%core_entry(ic)%core)
pdg_in(:,i) = core%data%get_pdg_in ()
end associate
if (i0 == 0) i0 = i
end if
end do
do i = 1, process%meta%n_components
if (.not. process%component(i)%active) then
pdg_in(:,i) = pdg_in(:,i0)
end if
end do
if (all (pdg_array_get_length (pdg_in) == 1) &
.and. all (pdg_in(1,:) == pdg_in(1,i0))) then
pdg_decay = pdg_array_get (pdg_in(:,i0), 1)
call flv_in%init (pdg_decay, process%config%model)
call process%beam_config%init_decay (flv_in, rest_frame, beam_structure)
else
call msg_fatal ("Setting up decay '" &
// char (process%meta%id) // "': decaying particle not unique")
end if
end subroutine process_setup_beams_decay
@ %def process_setup_beams_decay
@ We have to make sure that the masses of the various flavors
in a given position in the particle string coincide.
<<Process: process: TBP>>=
procedure :: check_masses => process_check_masses
<<Process: procedures>>=
subroutine process_check_masses (process)
class(process_t), intent(in) :: process
type(flavor_t), dimension(:), allocatable :: flv
real(default), dimension(:), allocatable :: mass
integer :: i, j
integer :: i_component
class(prc_core_t), pointer :: core
do i = 1, process%get_n_terms ()
i_component = process%term(i)%i_component
if (.not. process%component(i_component)%active) cycle
core => process%get_core_term (i)
associate (data => core%data)
allocate (flv (data%n_flv), mass (data%n_flv))
do j = 1, data%n_in + data%n_out
call flv%init (data%flv_state(j,:), process%config%model)
mass = flv%get_mass ()
if (any (.not. nearly_equal(mass, mass(1)))) then
call msg_fatal ("Process '" // char (process%meta%id) // "': " &
// "mass values in flavor combination do not coincide. ")
end if
end do
deallocate (flv, mass)
end associate
end do
end subroutine process_check_masses
@ %def process_check_masses
@ For some structure functions we need to get the list of initial
state flavors. This is a two-dimensional array. The first index is
the beam index, the second index is the component index. Each array
element is itself a PDG array object, which consists of the list of
incoming PDG values for this beam and component.
<<Process: process: TBP>>=
procedure :: get_pdg_in => process_get_pdg_in
<<Process: procedures>>=
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: procedures>>=
function process_get_phs_config (process, i_component) result (phs_config)
class(phs_config_t), pointer :: phs_config
class(process_t), intent(in), target :: process
integer, intent(in) :: i_component
if (allocated (process%component)) then
phs_config => process%component(i_component)%phs_config
else
phs_config => null ()
end if
end function process_get_phs_config
@ %def process_get_phs_config
@ The resonance history set can be extracted from the phase-space
configuration. However, this is only possible if the default phase-space
method (wood) has been chosen. If [[include_trivial]] is set, we include the
resonance history with no resonances in the set.
<<Process: process: TBP>>=
procedure :: extract_resonance_history_set &
=> process_extract_resonance_history_set
<<Process: procedures>>=
subroutine process_extract_resonance_history_set &
(process, res_set, include_trivial, i_component)
class(process_t), intent(in), target :: process
type(resonance_history_set_t), intent(out) :: res_set
logical, intent(in), optional :: include_trivial
integer, intent(in), optional :: i_component
integer :: i
i = 1; if (present (i_component)) i = i_component
select type (phs_config => process%get_phs_config (i))
class is (phs_wood_config_t)
call phs_config%extract_resonance_history_set (res_set, include_trivial)
class default
call msg_error ("process '" // char (process%get_id ()) &
// "': extract resonance histories: phase-space method must be &
&'wood'. No resonances can be determined.")
end select
end subroutine process_extract_resonance_history_set
@ %def process_extract_resonance_history_set
@ Initialize from a complete beam setup. If the beam setup does not
apply directly to the process, choose a fallback option as a straight
scattering or decay process.
<<Process: process: TBP>>=
procedure :: setup_beams_beam_structure => process_setup_beams_beam_structure
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_configure_phs (process, rebuild, ignore_mismatch, &
combined_integration, subdir)
class(process_t), intent(inout) :: process
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
logical, intent(in), optional :: combined_integration
type(string_t), intent(in), optional :: subdir
real(default) :: sqrts
integer :: i, i_born
class(phs_config_t), pointer :: phs_config_born
sqrts = process%get_sqrts ()
do i = 1, process%meta%n_components
associate (component => process%component(i))
if (component%active) then
select type (pcm => process%pcm)
type is (pcm_default_t)
call component%configure_phs (sqrts, process%beam_config, &
rebuild, ignore_mismatch, subdir)
class is (pcm_nlo_t)
select case (component%config%get_nlo_type ())
case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION)
call component%configure_phs (sqrts, process%beam_config, &
rebuild, ignore_mismatch, subdir)
call check_and_extend_phs (component)
case (NLO_REAL, NLO_MISMATCH, NLO_DGLAP)
i_born = component%config%get_associated_born ()
if (component%component_type /= COMP_REAL_FIN) &
call check_and_extend_phs (component)
call process%component(i_born)%get_phs_config (phs_config_born)
select type (config => component%phs_config)
type is (phs_fks_config_t)
select type (phs_config_born)
type is (phs_wood_config_t)
config%md5sum_born_config = phs_config_born%md5sum_phs_config
call config%set_born_config (phs_config_born)
call config%set_mode (component%config%get_nlo_type ())
end select
end select
call component%configure_phs (sqrts, &
process%beam_config, rebuild, ignore_mismatch, subdir)
end select
class default
call msg_bug ("process_configure_phs: unsupported PCM type")
end select
end if
end associate
end do
contains
subroutine check_and_extend_phs (component)
type(process_component_t), intent(inout) :: component
logical :: requires_dglap_random_number
if (combined_integration) then
requires_dglap_random_number = any (process%component%get_nlo_type () == NLO_DGLAP)
select type (phs_config => component%phs_config)
class is (phs_wood_config_t)
if (requires_dglap_random_number) then
call phs_config%set_extension_mode (EXTENSION_DGLAP)
else
call phs_config%set_extension_mode (EXTENSION_DEFAULT)
end if
call phs_config%increase_n_par ()
end select
end if
end subroutine check_and_extend_phs
end subroutine process_configure_phs
@ %def process_configure_phs
@
<<Process: process: TBP>>=
procedure :: print_phs_startup_message => process_print_phs_startup_message
<<Process: procedures>>=
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: procedures>>=
subroutine process_init_sf_chain (process, sf_config, sf_trace_file)
class(process_t), intent(inout) :: process
type(sf_config_t), dimension(:), intent(in) :: sf_config
type(string_t), intent(in), optional :: sf_trace_file
type(string_t) :: file
if (present (sf_trace_file)) then
if (sf_trace_file /= "") then
file = sf_trace_file
else
file = process%get_id () // "_sftrace.dat"
end if
call process%beam_config%init_sf_chain (sf_config, file)
else
call process%beam_config%init_sf_chain (sf_config)
end if
end subroutine process_init_sf_chain
subroutine process_set_sf_channel (process, c, sf_channel)
class(process_t), intent(inout) :: process
integer, intent(in) :: c
type(sf_channel_t), intent(in) :: sf_channel
call process%beam_config%set_sf_channel (c, sf_channel)
end subroutine process_set_sf_channel
subroutine process_set_sf_channel_array (process, sf_channel)
class(process_t), intent(inout) :: process
type(sf_channel_t), dimension(:), intent(in) :: sf_channel
integer :: c
call process%beam_config%allocate_sf_channels (size (sf_channel))
do c = 1, size (sf_channel)
call process%beam_config%set_sf_channel (c, sf_channel(c))
end do
end subroutine process_set_sf_channel_array
@ %def process_init_sf_chain
@ %def process_set_sf_channel
@ Notify about the structure-function setup.
<<Process: process: TBP>>=
procedure :: sf_startup_message => process_sf_startup_message
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_set_scale (process, ef_scale)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_scale
allocate (process%config%ef_scale, source = ef_scale)
end subroutine process_set_scale
subroutine process_set_fac_scale (process, ef_fac_scale)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_fac_scale
allocate (process%config%ef_fac_scale, source = ef_fac_scale)
end subroutine process_set_fac_scale
subroutine process_set_ren_scale (process, ef_ren_scale)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_ren_scale
allocate (process%config%ef_ren_scale, source = ef_ren_scale)
end subroutine process_set_ren_scale
subroutine process_set_weight (process, ef_weight)
class(process_t), intent(inout) :: process
class(expr_factory_t), intent(in) :: ef_weight
allocate (process%config%ef_weight, source = ef_weight)
end subroutine process_set_weight
@ %def process_set_scale
@ %def process_set_fac_scale
@ %def process_set_ren_scale
@ %def process_set_weight
@
\subsubsection{MD5 sum}
The MD5 sum of the process object should reflect the state completely,
including integration results. It is used for checking the integrity
of event files. This global checksum includes checksums for the
various parts. In particular, the MCI object receives a checksum that
includes the configuration of all configuration parts relevant for an
individual integration. This checksum is used for checking the
integrity of integration grids.
We do not need MD5 sums for the process terms, since these are
generated from the component definitions.
<<Process: process: TBP>>=
procedure :: compute_md5sum => process_compute_md5sum
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_final_integration (process, i_mci)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_mci
call process%mci_entry(i_mci)%final_integration ()
end subroutine process_final_integration
subroutine process_integrate_dummy (process)
class(process_t), intent(inout) :: process
type(integration_results_t) :: results
integer :: u_log
u_log = logfile_unit ()
call results%init (process%meta%type)
call results%display_init (screen = .true., unit = u_log)
call results%new_pass ()
call results%record (1, 0, 0._default, 0._default, 0._default)
call results%display_final ()
end subroutine process_integrate_dummy
@ %def process_final_integration
@ %def process_integrate_dummy
@
<<Process: process: TBP>>=
procedure :: integrate => process_integrate
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
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.)
<<Process: process: TBP>>=
procedure :: display_summed_results => process_display_summed_results
<<Process: procedures>>=
subroutine process_display_summed_results (process, pacify)
class(process_t), intent(inout) :: process
logical, intent(in) :: pacify
type(integration_results_t) :: results
integer :: u_log
u_log = logfile_unit ()
call results%init (process%meta%type)
call results%display_init (screen = .true., unit = u_log)
call results%new_pass ()
call results%record (1, 0, &
process%get_integral (), &
process%get_error (), &
process%get_efficiency (), suppress = pacify)
select type (pcm => process%pcm)
class is (pcm_nlo_t)
!!! Check that Born integral is there
if (process%component_can_be_integrated (1)) then
call results%record_correction (process%get_correction (), &
process%get_correction_error ())
end if
end select
call results%display_final ()
end subroutine process_display_summed_results
@ %def process_display_summed_results
@ Run LaTeX/Metapost to generate a ps/pdf file for the integration
history. We (re)write the driver file -- just in case it has been
missed before -- then we compile it.
<<Process: process: TBP>>=
procedure :: display_integration_history => &
process_display_integration_history
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
function process_has_integral_mci (process, i_mci) result (flag)
logical :: flag
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
if (allocated (process%mci_entry)) then
flag = process%mci_entry(i_mci)%has_integral ()
else
flag = .false.
end if
end function process_has_integral_mci
function process_has_integral_tot (process) result (flag)
logical :: flag
class(process_t), intent(in) :: process
integer :: i, j, i_component
if (allocated (process%mci_entry)) then
flag = .true.
do i = 1, size (process%mci_entry)
do j = 1, size (process%mci_entry(i)%i_component)
i_component = process%mci_entry(i)%i_component(j)
if (process%component_can_be_integrated (i_component)) &
flag = flag .and. process%mci_entry(i)%has_integral ()
end do
end do
else
flag = .false.
end if
end function process_has_integral_tot
@ %def process_has_integral
@
Return the current integral and error obtained by the integrator [[i_mci]].
<<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: procedures>>=
function process_get_integral_mci (process, i_mci) result (integral)
real(default) :: integral
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
integral = process%mci_entry(i_mci)%get_integral ()
end function process_get_integral_mci
function process_get_error_mci (process, i_mci) result (error)
real(default) :: error
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
error = process%mci_entry(i_mci)%get_error ()
end function process_get_error_mci
function process_get_efficiency_mci (process, i_mci) result (efficiency)
real(default) :: efficiency
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
efficiency = process%mci_entry(i_mci)%get_efficiency ()
end function process_get_efficiency_mci
function process_get_integral_tot (process) result (integral)
real(default) :: integral
class(process_t), intent(in) :: process
integer :: i, j, i_component
integral = zero
if (allocated (process%mci_entry)) then
do i = 1, size (process%mci_entry)
do j = 1, size (process%mci_entry(i)%i_component)
i_component = process%mci_entry(i)%i_component(j)
if (process%component_can_be_integrated(i_component)) &
integral = integral + process%mci_entry(i)%get_integral ()
end do
end do
end if
end function process_get_integral_tot
function process_get_error_tot (process) result (error)
real(default) :: variance
class(process_t), intent(in) :: process
real(default) :: error
integer :: i, j, i_component
variance = zero
if (allocated (process%mci_entry)) then
do i = 1, size (process%mci_entry)
do j = 1, size (process%mci_entry(i)%i_component)
i_component = process%mci_entry(i)%i_component(j)
if (process%component_can_be_integrated(i_component)) &
variance = variance + process%mci_entry(i)%get_error () ** 2
end do
end do
end if
error = sqrt (variance)
end function process_get_error_tot
function process_get_efficiency_tot (process) result (efficiency)
real(default) :: efficiency
class(process_t), intent(in) :: process
real(default) :: den, eff, int
integer :: i, j, i_component
den = zero
if (allocated (process%mci_entry)) then
do i = 1, size (process%mci_entry)
do j = 1, size (process%mci_entry(i)%i_component)
i_component = process%mci_entry(i)%i_component(j)
if (process%component_can_be_integrated(i_component)) then
int = process%get_integral (i)
if (int > 0) then
eff = process%mci_entry(i)%get_efficiency ()
if (eff > 0) then
den = den + int / eff
else
efficiency = 0
return
end if
end if
end if
end do
end do
end if
if (den > 0) then
efficiency = process%get_integral () / den
else
efficiency = 0
end if
end function process_get_efficiency_tot
@ %def process_get_integral process_get_efficiency
@ Let us call the ratio of the LO and the NLO result $\iota = I_{LO} / I_{NLO}$. Then
usual error propagation gives
\begin{equation*}
\sigma_{\iota}^2 = \left(\frac{\partial \iota}{\partial I_{LO}}\right)^2 \sigma_{I_{LO}}^2
+ \left(\frac{\partial \iota}{\partial I_{NLO}}\right)^2 \sigma_{I_{NLO}}^2
= \frac{I_{NLO}^2\sigma_{I_{LO}}^2}{I_{LO}^4} + \frac{\sigma_{I_{NLO}}^2}{I_{LO}^2}.
\end{equation*}
<<Process: process: TBP>>=
procedure :: get_correction => process_get_correction
procedure :: get_correction_error => process_get_correction_error
<<Process: procedures>>=
function process_get_correction (process) result (ratio)
real(default) :: ratio
class(process_t), intent(in) :: process
integer :: i_mci
real(default) :: int_born, int_nlo
int_nlo = zero
int_born = process%mci_entry(1)%get_integral ()
do i_mci = 2, size (process%mci_entry)
if (process%component_can_be_integrated (i_mci)) &
int_nlo = int_nlo + process%mci_entry(i_mci)%get_integral ()
end do
ratio = int_nlo / int_born * 100
end function process_get_correction
function process_get_correction_error (process) result (error)
real(default) :: error
class(process_t), intent(in) :: process
real(default) :: int_born, sum_int_nlo
real(default) :: err_born, err2
integer :: i_mci
sum_int_nlo = zero; err2 = zero
int_born = process%mci_entry(1)%get_integral ()
err_born = process%mci_entry(1)%get_error ()
do i_mci = 2, size (process%mci_entry)
if (process%component_can_be_integrated (i_mci)) then
sum_int_nlo = sum_int_nlo + process%mci_entry(i_mci)%get_integral ()
err2 = err2 + process%mci_entry(i_mci)%get_error()**2
end if
end do
error = sqrt (err2 / int_born**2 + sum_int_nlo**2 * err_born**2 / int_born**4) * 100
end function process_get_correction_error
@ %def process_get_correction process_get_correction_error
@
<<Process: process: TBP>>=
procedure :: lab_is_cm_frame => process_lab_is_cm_frame
<<Process: procedures>>=
pure function process_lab_is_cm_frame (process) result (cm_frame)
logical :: cm_frame
class(process_t), intent(in) :: process
cm_frame = process%beam_config%lab_is_cm_frame
end function process_lab_is_cm_frame
@ %def process_lab_is_cm_frame
@
<<Process: process: TBP>>=
procedure :: get_component_ptr => process_get_component_ptr
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
elemental function process_get_component_type_single &
(process, i_component) result (comp_type)
integer :: comp_type
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
comp_type = process%component(i_component)%component_type
end function process_get_component_type_single
@ %def process_get_component_type_single
@
<<Process: process: TBP>>=
generic :: get_component_type => get_component_type_all
procedure :: get_component_type_all => process_get_component_type_all
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
pure subroutine process_reset_selected_cores (process)
class(process_t), intent(inout) :: process
process%pcm%component_selected = .false.
end subroutine process_reset_selected_cores
@ %def process_reset_selected_cores
@
<<Process: process: TBP>>=
procedure :: select_components => process_select_components
<<Process: procedures>>=
pure subroutine process_select_components (process, indices)
class(process_t), intent(inout) :: process
integer, dimension(:), intent(in) :: indices
associate (pcm => process%pcm)
pcm%component_selected(indices) = .true.
end associate
end subroutine process_select_components
@ %def process_select_components
@
<<Process: process: TBP>>=
procedure :: component_is_selected => process_component_is_selected
<<Process: procedures>>=
pure function process_component_is_selected (process, index) result (val)
logical :: val
class(process_t), intent(in) :: process
integer, intent(in) :: index
associate (pcm => process%pcm)
val = pcm%component_selected(index)
end associate
end function process_component_is_selected
@ %def process_component_is_selected
@
<<Process: process: TBP>>=
procedure :: get_coupling_powers => process_get_coupling_powers
<<Process: procedures>>=
pure subroutine process_get_coupling_powers (process, alpha_power, alphas_power)
class(process_t), intent(in) :: process
integer, intent(out) :: alpha_power, alphas_power
call process%component(1)%config%get_coupling_powers (alpha_power, alphas_power)
end subroutine process_get_coupling_powers
@ %def process_get_coupling_powers
@
<<Process: process: TBP>>=
procedure :: get_real_component => process_get_real_component
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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 :: set_i_mci_work => process_set_i_mci_work
<<Process: procedures>>=
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: procedures>>=
pure function process_get_i_mci_work (process, i_mci) result (i_mci_work)
integer :: i_mci_work
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
i_mci_work = process%mci_entry(i_mci)%i_mci
end function process_get_i_mci_work
@ %def process_get_i_mci_work
@
<<Process: process: TBP>>=
procedure :: get_i_sub => process_get_i_sub
<<Process: procedures>>=
elemental function process_get_i_sub (process, i_term) result (i_sub)
integer :: i_sub
class(process_t), intent(in) :: process
integer, intent(in) :: i_term
i_sub = process%term(i_term)%i_sub
end function process_get_i_sub
@ %def process_get_i_sub
@
<<Process: process: TBP>>=
procedure :: get_i_term_virtual => process_get_i_term_virtual
<<Process: procedures>>=
elemental function process_get_i_term_virtual (process) result (i_term)
integer :: i_term
class(process_t), intent(in) :: process
integer :: i_component
i_term = 0
do i_component = 1, size (process%component)
if (process%component(i_component)%get_nlo_type () == NLO_VIRTUAL) &
i_term = process%component(i_component)%i_term(1)
end do
end function process_get_i_term_virtual
@ %def process_get_i_term_virtual
@
<<Process: process: TBP>>=
generic :: component_is_active => component_is_active_single
procedure :: component_is_active_single => process_component_is_active_single
<<Process: procedures>>=
elemental function process_component_is_active_single (process, i_comp) result (val)
logical :: val
class(process_t), intent(in) :: process
integer, intent(in) :: i_comp
val = process%component(i_comp)%is_active ()
end function process_component_is_active_single
@ %def process_component_is_active_single
@
<<Process: process: TBP>>=
generic :: component_is_active => component_is_active_all
procedure :: component_is_active_all => process_component_is_active_all
<<Process: procedures>>=
pure function process_component_is_active_all (process) result (val)
logical, dimension(:), allocatable :: val
class(process_t), intent(in) :: process
allocate (val (size (process%component)))
val = process%component%is_active ()
end function process_component_is_active_all
@ %def process_component_is_active_all
@
\subsection{Default iterations}
If the user does not specify the passes and iterations for
integration, we should be able to give reasonable defaults. These
depend on the process, therefore we implement the following procedures
as methods of the process object. The algorithm is not very
sophisticated yet, it may be improved by looking at the process in
more detail.
We investigate only the first process component, assuming that it
characterizes the complexity of the process reasonable well.
The number of passes is limited to two: one for adaption, one for
integration.
<<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: procedures>>=
function process_get_n_pass_default (process) result (n_pass)
class(process_t), intent(in) :: process
integer :: n_pass
integer :: n_eff
type(process_component_def_t), pointer :: config
config => process%component(1)%config
n_eff = config%get_n_tot () - 2
select case (n_eff)
case (1)
n_pass = 1
case default
n_pass = 2
end select
end function process_get_n_pass_default
function process_adapt_grids_default (process, pass) result (flag)
class(process_t), intent(in) :: process
integer, intent(in) :: pass
logical :: flag
integer :: n_eff
type(process_component_def_t), pointer :: config
config => process%component(1)%config
n_eff = config%get_n_tot () - 2
select case (n_eff)
case (1)
flag = .false.
case default
select case (pass)
case (1); flag = .true.
case (2); flag = .false.
case default
call msg_bug ("adapt grids default: impossible pass index")
end select
end select
end function process_adapt_grids_default
function process_adapt_weights_default (process, pass) result (flag)
class(process_t), intent(in) :: process
integer, intent(in) :: pass
logical :: flag
integer :: n_eff
type(process_component_def_t), pointer :: config
config => process%component(1)%config
n_eff = config%get_n_tot () - 2
select case (n_eff)
case (1)
flag = .false.
case default
select case (pass)
case (1); flag = .true.
case (2); flag = .false.
case default
call msg_bug ("adapt weights default: impossible pass index")
end select
end select
end function process_adapt_weights_default
@ %def process_get_n_pass_default
@ %def process_adapt_grids_default
@ %def process_adapt_weights_default
@ The number of iterations and calls per iteration depends on the
number of outgoing particles.
<<Process: process: TBP>>=
procedure :: get_n_it_default => process_get_n_it_default
procedure :: get_n_calls_default => process_get_n_calls_default
<<Process: procedures>>=
function process_get_n_it_default (process, pass) result (n_it)
class(process_t), intent(in) :: process
integer, intent(in) :: pass
integer :: n_it
integer :: n_eff
type(process_component_def_t), pointer :: config
config => process%component(1)%config
n_eff = config%get_n_tot () - 2
select case (pass)
case (1)
select case (n_eff)
case (1); n_it = 1
case (2); n_it = 3
case (3); n_it = 5
case (4:5); n_it = 10
case (6); n_it = 15
case (7:); n_it = 20
end select
case (2)
select case (n_eff)
case (:3); n_it = 3
case (4:); n_it = 5
end select
end select
end function process_get_n_it_default
function process_get_n_calls_default (process, pass) result (n_calls)
class(process_t), intent(in) :: process
integer, intent(in) :: pass
integer :: n_calls
integer :: n_eff
type(process_component_def_t), pointer :: config
config => process%component(1)%config
n_eff = config%get_n_tot () - 2
select case (pass)
case (1)
select case (n_eff)
case (1); n_calls = 100
case (2); n_calls = 1000
case (3); n_calls = 5000
case (4); n_calls = 10000
case (5); n_calls = 20000
case (6:); n_calls = 50000
end select
case (2)
select case (n_eff)
case (:3); n_calls = 10000
case (4); n_calls = 20000
case (5); n_calls = 50000
case (6); n_calls = 100000
case (7:); n_calls = 200000
end select
end select
end function process_get_n_calls_default
@ %def process_get_n_it_default
@ %def process_get_n_calls_default
@
\subsection{Constant process data}
Manually set the Run ID (unit test only).
<<Process: process: TBP>>=
procedure :: set_run_id => process_set_run_id
<<Process: procedures>>=
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: procedures>>=
function process_get_id (process) result (id)
class(process_t), intent(in) :: process
type(string_t) :: id
id = process%meta%id
end function process_get_id
function process_get_num_id (process) result (id)
class(process_t), intent(in) :: process
integer :: id
id = process%meta%num_id
end function process_get_num_id
function process_get_run_id (process) result (id)
class(process_t), intent(in) :: process
type(string_t) :: id
id = process%meta%run_id
end function process_get_run_id
function process_get_library_name (process) result (id)
class(process_t), intent(in) :: process
type(string_t) :: id
id = process%meta%lib_name
end function process_get_library_name
@ %def process_get_id process_get_num_id
@ %def process_get_run_id process_get_library_name
@ The number of incoming particles.
<<Process: process: TBP>>=
procedure :: get_n_in => process_get_n_in
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_extract_core (process, i_term, core)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_term
class(prc_core_t), intent(inout), allocatable :: core
integer :: i_core
i_core = process%term(i_term)%i_core
call move_alloc (from = process%core_entry(i_core)%core, to = core)
end subroutine process_extract_core
subroutine process_restore_core (process, i_term, core)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_term
class(prc_core_t), intent(inout), allocatable :: core
integer :: i_core
i_core = process%term(i_term)%i_core
call move_alloc (from = core, to = process%core_entry(i_core)%core)
end subroutine process_restore_core
@ %def process_extract_core
@ %def process_restore_core
@ The block of process constants.
<<Process: process: TBP>>=
procedure :: get_constants => process_get_constants
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_get_term_flv_out (process, i_term, flv)
class(process_t), intent(in), target :: process
integer, intent(in) :: i_term
type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv
type(interaction_t), pointer :: int
int => process%term(i_term)%int_eff
if (.not. associated (int)) int => process%term(i_term)%int
call interaction_get_flv_out (int, flv)
end subroutine process_get_term_flv_out
@ %def process_get_term_flv_out
@ Return true if there is any unstable particle in any of the process
terms. We decide this based on the provided model instance, not the
one that is stored in the process object.
<<Process: process: TBP>>=
procedure :: contains_unstable => process_contains_unstable
<<Process: procedures>>=
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: procedures>>=
function process_get_sqrts (process) result (sqrts)
class(process_t), intent(in) :: process
real(default) :: sqrts
sqrts = process%beam_config%data%get_sqrts ()
end function process_get_sqrts
@ %def process_get_sqrts
@ The beam polarization in case of simple degrees.
<<Process: process: TBP>>=
procedure :: get_polarization => process_get_polarization
<<Process: procedures>>=
function process_get_polarization (process) result (pol)
class(process_t), intent(in) :: process
real(default), dimension(2) :: pol
pol = process%beam_config%data%get_polarization ()
end function process_get_polarization
@ %def process_get_polarization
@
<<Process: process: TBP>>=
procedure :: get_meta => process_get_meta
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
function process_get_beam_config_ptr (process) result (beam_config)
type(process_beam_config_t), pointer :: beam_config
class(process_t), intent(in), target :: process
beam_config => process%beam_config
end function process_get_beam_config_ptr
@ %def process_get_beam_config_ptr
@ Return true if lab and c.m.\ frame coincide for this process.
<<Process: process: TBP>>=
procedure :: cm_frame => process_cm_frame
<<Process: procedures>>=
function process_cm_frame (process) result (flag)
class(process_t), intent(in), target :: process
logical :: flag
type(beam_data_t), pointer :: beam_data
beam_data => process%beam_config%data
flag = beam_data%cm_frame ()
end function process_cm_frame
@ %def process_cm_frame
@ Get the PDF set currently in use, if any.
<<Process: process: TBP>>=
procedure :: get_pdf_set => process_get_pdf_set
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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_component_type => process_set_component_type
<<Process: procedures>>=
subroutine process_set_component_type (process, i_component, i_type)
class(process_t), intent(inout) :: process
integer, intent(in) :: i_component, i_type
process%component(i_component)%component_type = i_type
end subroutine process_set_component_type
@ %def process_set_component_type
@
<<Process: process: TBP>>=
procedure :: set_counter_mci_entry => process_set_counter_mci_entry
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine test_allocate_sf_channels (process, n)
class(process_t), intent(inout) :: process
integer, intent(in) :: n
call process%beam_config%allocate_sf_channels (n)
end subroutine test_allocate_sf_channels
subroutine test_set_component_sf_channel (process, c)
class(process_t), intent(inout) :: process
integer, dimension(:), intent(in) :: c
call process%component(1)%phs_config%set_sf_channel (c)
end subroutine test_set_component_sf_channel
subroutine test_get_mci_ptr (process, mci)
class(process_t), intent(in), target :: process
class(mci_t), intent(out), pointer :: mci
mci => process%mci_entry(1)%mci
end subroutine test_get_mci_ptr
@ %def test_allocate_sf_channels
@ %def test_set_component_sf_channel
@ %def test_get_mci_ptr
@
<<Process: process: TBP>>=
procedure :: init_mci_work => process_init_mci_work
<<Process: procedures>>=
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.
<<Process: process: TBP>>=
procedure :: setup_test_cores => process_setup_test_cores
<<Process: procedures>>=
subroutine process_setup_test_cores (process, type_string)
class(process_t), intent(inout) :: process
class(prc_core_t), allocatable :: core
type(string_t), intent(in), optional :: type_string
if (present (type_string)) then
select case (char (type_string))
case ("template")
call process%setup_cores (dispatch_template_core)
case ("test_me")
call process%setup_cores (dispatch_test_me_core)
case default
call msg_bug ("process setup test cores: unsupported type string")
end select
else
call process%setup_cores (dispatch_test_me_core)
end if
end subroutine process_setup_test_cores
subroutine dispatch_test_me_core (core, core_def, model, &
helicity_selection, qcd, use_color_factors, has_beam_pol)
use prc_test_core, only: test_t
class(prc_core_t), allocatable, intent(inout) :: core
class(prc_core_def_t), intent(in) :: core_def
class(model_data_t), intent(in), target, optional :: model
type(helicity_selection_t), intent(in), optional :: helicity_selection
type(qcd_t), intent(in), optional :: qcd
logical, intent(in), optional :: use_color_factors
logical, intent(in), optional :: has_beam_pol
allocate (test_t :: core)
end subroutine dispatch_test_me_core
subroutine dispatch_template_core (core, core_def, model, &
helicity_selection, qcd, use_color_factors, has_beam_pol)
use prc_template_me, only: prc_template_me_t
class(prc_core_t), allocatable, intent(inout) :: core
class(prc_core_def_t), intent(in) :: core_def
class(model_data_t), intent(in), target, optional :: model
type(helicity_selection_t), intent(in), optional :: helicity_selection
type(qcd_t), intent(in), optional :: qcd
logical, intent(in), optional :: use_color_factors
logical, intent(in), optional :: has_beam_pol
allocate (prc_template_me_t :: core)
select type (core)
type is (prc_template_me_t)
call core%set_parameters (model)
end select
end subroutine dispatch_template_core
@ %def process_setup_test_cores
@
<<Process: process: TBP>>=
procedure :: get_connected_states => process_get_connected_states
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
elemental function process_get_nlo_type_component_single (process, i_component) result (val)
integer :: val
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
val = process%component(i_component)%get_nlo_type ()
end function process_get_nlo_type_component_single
@ %def process_get_nlo_type_component_single
@
<<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: procedures>>=
pure function process_get_nlo_type_component_all (process) result (val)
integer, dimension(:), allocatable :: val
class(process_t), intent(in) :: process
allocate (val (size (process%component)))
val = process%component%get_nlo_type ()
end function process_get_nlo_type_component_all
@ %def process_get_nlo_type_component_all
@
<<Process: process: TBP>>=
procedure :: is_nlo_calculation => process_is_nlo_calculation
<<Process: procedures>>=
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 :: is_combined_nlo_integration &
=> process_is_combined_nlo_integration
<<Process: procedures>>=
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: procedures>>=
pure function process_component_is_real_finite (process, i_component) &
result (val)
logical :: val
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
val = process%component(i_component)%component_type == COMP_REAL_FIN
end function process_component_is_real_finite
@ %def process_component_is_real_finite
@ Return nlo data of a process component
<<Process: process: TBP>>=
procedure :: get_component_nlo_type => process_get_component_nlo_type
<<Process: procedures>>=
elemental function process_get_component_nlo_type (process, i_component) &
result (nlo_type)
integer :: nlo_type
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
nlo_type = process%component(i_component)%config%get_nlo_type ()
end function process_get_component_nlo_type
@ %def process_get_component_nlo_type
@ Return a pointer to the core that belongs to a component.
<<Process: process: TBP>>=
procedure :: get_component_core_ptr => process_get_component_core_ptr
<<Process: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
elemental function process_get_associated_real_fin (process, i_component) result (i_real)
integer :: i_real
class(process_t), intent(in) :: process
integer, intent(in) :: i_component
i_real = process%component(i_component)%config%get_associated_real_fin ()
end function process_get_associated_real_fin
@ %def process_get_associated_real_fin
@
<<Process: process: TBP>>=
procedure :: select_i_term => process_select_i_term
<<Process: procedures>>=
pure function process_select_i_term (process, i_mci) result (i_term)
integer :: i_term
class(process_t), intent(in) :: process
integer, intent(in) :: i_mci
integer :: i_component, i_sub
i_component = process%mci_entry(i_mci)%i_component(1)
i_term = process%component(i_component)%i_term(1)
i_sub = process%term(i_term)%i_sub
if (i_sub > 0) &
i_term = process%term(i_sub)%i_term_global
end function process_select_i_term
@ %def process_select_i_term
@ Would be better to do this at the level of the writer of the core but
one has to bring NLO information there.
<<Process: process: TBP>>=
procedure :: prepare_any_external_code &
=> process_prepare_any_external_code
<<Process: procedures>>=
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 format_utils, only: write_separator
use io_units
use md5
use os_interface
use diagnostics
use sf_base
use sf_mappings
use mappings, only: mapping_defaults_t
use phs_forests, only: phs_parameters_t
use sm_qcd
use physics_defs
use integration_results
use model_data
use models
use interactions
use quantum_numbers
use flavors
use helicities
use colors
use rng_base
use state_matrices
use process_libraries
use process_constants
use prc_core
use prc_external
use prc_openloops, only: prc_openloops_t
use prc_threshold, only: prc_threshold_t
use beams
use dispatch_beams, only: dispatch_qcd
use mci_base
use beam_structures
use phs_base
use variables
use expr_base
use blha_olp_interfaces, only: prc_blha_t
<<Standard module head>>
<<Process config: public>>
<<Process config: parameters>>
<<Process config: types>>
contains
<<Process config: procedures>>
end module process_config
@ %def process_config
@ 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: procedures>>=
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: procedures>>=
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: procedures>>=
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.
<<Process config: process config data: TBP>>=
procedure :: init => process_config_data_init
<<Process config: 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
@ Current implementation: nothing to finalize.
<<Process config: process config data: TBP>>=
procedure :: final => process_config_data_final
<<Process config: procedures>>=
subroutine process_config_data_final (config)
class(process_config_data_t), intent(inout) :: config
end subroutine process_config_data_final
@ %def process_config_data_final
@ Return a copy of the QCD data block.
<<Process config: process config data: TBP>>=
procedure :: get_qcd => process_config_data_get_qcd
<<Process config: procedures>>=
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: procedures>>=
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: procedures>>=
pure function process_config_data_get_md5sum (config) result (md5)
character(32) :: md5
class(process_config_data_t), intent(in) :: config
md5 = config%md5sum
end function process_config_data_get_md5sum
@ %def process_config_data_get_md5sum
@
\subsection{Environment}
This record stores a snapshot of the process environment at the point where
the process object is created.
Model and variable list are implemented as pointer, so they always have the
[[target]] attribute.
For unit-testing purposes, setting the var list is optional. If not set, the
pointer is null.
<<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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_metadata_init (meta, id, lib, var_list)
class(process_metadata_t), intent(out) :: meta
type(string_t), intent(in) :: id
type(process_library_t), intent(in), target :: lib
type(var_list_t), intent(in) :: var_list
select case (lib%get_n_in (id))
case (1); meta%type = PRC_DECAY
case (2); meta%type = PRC_SCATTERING
case default
call msg_bug ("Process '" // char (id) // "': impossible n_in")
end select
meta%id = id
meta%run_id = var_list%get_sval (var_str ("$run_id"))
allocate (meta%lib_name)
meta%lib_name = lib%get_name ()
meta%lib_update_counter = lib%get_update_counter ()
if (lib%contains (id)) then
meta%lib_index = lib%get_entry_index (id)
meta%num_id = lib%get_num_id (id)
call lib%get_component_list (id, meta%component_id)
meta%n_components = size (meta%component_id)
call lib%get_component_description_list &
(id, meta%component_description)
allocate (meta%active (meta%n_components), source = .true.)
else
call msg_fatal ("Process library doesn't contain process '" &
// char (id) // "'")
end if
if (.not. lib%is_active ()) then
call msg_bug ("Process init: inactive library not handled yet")
end if
end subroutine process_metadata_init
@ %def process_metadata_init
@ Mark a component as inactive.
<<Process config: process metadata: TBP>>=
procedure :: deactivate_component => process_metadata_deactivate_component
<<Process config: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_phs_config_write_formatted &
(dtv, unit, iotype, v_list, iostat, iomsg)
class(process_phs_config_t), intent(in) :: dtv
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, dimension(:), intent(in) :: v_list
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
associate (phs_config => dtv)
write (unit, "(1x, A)") "Phase-space configuration entry:"
call phs_config%phs_par%write (unit)
call phs_config%mapping_defs%write (unit)
end associate
iostat = 0
end subroutine process_phs_config_write_formatted
@ %def process_phs_config_write_formatted
@
\subsection{Beam configuration}
The object [[data]] holds all details about the initial beam
configuration. The allocatable array [[sf]] holds the structure-function
configuration blocks. There are [[n_strfun]] entries in the
structure-function chain (not counting the initial beam object). We
maintain [[n_channel]] independent parameterizations of this chain.
If this is greater than zero, we need a multi-channel sampling
algorithm, where for each point one channel is selected to generate
kinematics.
The number of parameters that are required for generating a
structure-function chain is [[n_sfpar]].
The flag [[azimuthal_dependence]] tells whether the process setup is
symmetric about the beam axis in the c.m.\ system. This implies that
there is no transversal beam polarization. The flag [[lab_is_cm_frame]] is
obvious.
<<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_frame = .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: procedures>>=
subroutine process_beam_config_write (object, unit, verbose)
class(process_beam_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer :: u, i, c
u = given_output_unit (unit)
call object%data%write (u, verbose = verbose)
if (object%data%initialized) then
write (u, "(3x,A,L1)") "Azimuthal dependence = ", &
object%azimuthal_dependence
write (u, "(3x,A,L1)") "Lab frame is c.m. frame = ", &
object%lab_is_cm_frame
if (object%md5sum /= "") then
write (u, "(3x,A,A,A)") "MD5 sum (beams/strf) = '", &
object%md5sum, "'"
end if
if (allocated (object%sf)) then
do i = 1, size (object%sf)
call object%sf(i)%write (u)
end do
if (any_sf_channel_has_mapping (object%sf_channel)) then
write (u, "(1x,A,L1)") "Structure-function mappings per channel:"
do c = 1, object%n_channel
write (u, "(3x,I0,':')", advance="no") c
call object%sf_channel(c)%write (u)
end do
end if
end if
end if
end subroutine process_beam_config_write
@ %def process_beam_config_write
@ The beam data have a finalizer. We assume that there is none for the
structure-function data.
<<Process config: process beam config: TBP>>=
procedure :: final => process_beam_config_final
<<Process config: procedures>>=
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: procedures>>=
subroutine process_beam_config_init_beam_structure &
(beam_config, beam_structure, sqrts, model, decay_rest_frame)
class(process_beam_config_t), intent(out) :: beam_config
type(beam_structure_t), intent(in) :: beam_structure
logical, intent(in), optional :: decay_rest_frame
real(default), intent(in) :: sqrts
class(model_data_t), intent(in), target :: model
call beam_config%data%init_structure (beam_structure, &
sqrts, model, decay_rest_frame)
beam_config%lab_is_cm_frame = beam_config%data%cm_frame ()
end subroutine process_beam_config_init_beam_structure
@ %def process_beam_config_init_beam_structure
@ Initialize the beam setup for a scattering process with specified
flavor combination, other properties taken from the beam structure
object (if any).
<<Process config: process beam config: TBP>>=
procedure :: init_scattering => process_beam_config_init_scattering
<<Process config: procedures>>=
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: procedures>>=
subroutine process_beam_config_init_decay &
(beam_config, flv_in, rest_frame, beam_structure)
class(process_beam_config_t), intent(out) :: beam_config
type(flavor_t), dimension(1), intent(in) :: flv_in
logical, intent(in), optional :: rest_frame
type(beam_structure_t), intent(in), optional :: beam_structure
if (present (beam_structure)) then
if (beam_structure%polarized ()) then
call beam_config%data%init_decay (flv_in, &
beam_structure%get_smatrix (), beam_structure%get_pol_f (), &
rest_frame = rest_frame)
else
call beam_config%data%init_decay (flv_in, rest_frame = rest_frame)
end if
else
call beam_config%data%init_decay (flv_in, &
rest_frame = rest_frame)
end if
beam_config%lab_is_cm_frame = beam_config%data%cm_frame ()
end subroutine process_beam_config_init_decay
@ %def process_beam_config_init_decay
@ Print an informative message.
<<Process config: process beam config: TBP>>=
procedure :: startup_message => process_beam_config_startup_message
<<Process config: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
pure function process_beam_config_get_md5sum (beam_config) result (md5)
character(32) :: md5
class(process_beam_config_t), intent(in) :: beam_config
md5 = beam_config%md5sum
end function process_beam_config_get_md5sum
@ %def process_beam_config_get_md5sum
@
<<Process config: process beam config: TBP>>=
procedure :: has_structure_function => process_beam_config_has_structure_function
<<Process config: procedures>>=
pure function process_beam_config_has_structure_function (beam_config) result (has_sf)
logical :: has_sf
class(process_beam_config_t), intent(in) :: beam_config
has_sf = beam_config%n_strfun > 0
end function process_beam_config_has_structure_function
@ %def process_beam_config_has_structure_function
@
\subsection{Process components}
A process component is an individual contribution to a process
(scattering or decay) which needs not be physical. The sum over all
components should be physical.
The [[index]] indentifies this component within its parent process.
The actual process component is stored in the [[core]] subobject. We
use a polymorphic subobject instead of an extension of
[[process_component_t]], because the individual entries in the array
of process components can have different types. In short,
[[process_component_t]] is a wrapper for the actual process variants.
If the [[active]] flag is false, we should skip this component. This happens
if the associated process has vanishing matrix element.
The index array [[i_term]] points to the individual terms generated by
this component. The indices refer to the parent process.
The index [[i_mci]] is the index of the MC integrator and parameter set which
are associated to this process component.
<<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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
elemental function process_component_is_active (component) result (active)
logical :: active
class(process_component_t), intent(in) :: component
active = component%active
end function process_component_is_active
@ %def process_component_is_active
@ Finalize the phase-space configuration.
<<Process config: process component: TBP>>=
procedure :: configure_phs => process_component_configure_phs
<<Process config: procedures>>=
subroutine process_component_configure_phs &
(component, sqrts, beam_config, rebuild, &
ignore_mismatch, subdir)
class(process_component_t), intent(inout) :: component
real(default), intent(in) :: sqrts
type(process_beam_config_t), intent(in) :: beam_config
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
type(string_t), intent(in), optional :: subdir
logical :: no_strfun
integer :: nlo_type
no_strfun = beam_config%n_strfun == 0
nlo_type = component%config%get_nlo_type ()
call component%phs_config%configure (sqrts, &
azimuthal_dependence = beam_config%azimuthal_dependence, &
sqrts_fixed = no_strfun, &
cm_frame = beam_config%lab_is_cm_frame .and. no_strfun, &
rebuild = rebuild, ignore_mismatch = ignore_mismatch, &
nlo_type = nlo_type, &
subdir = subdir)
end subroutine process_component_configure_phs
@ %def process_component_configure_phs
@ The process component possesses two MD5 sums: the checksum of the
component definition, which should be available when the component is
initialized, and the phase-space MD5 sum, which is available after
configuration.
<<Process config: process component: TBP>>=
procedure :: compute_md5sum => process_component_compute_md5sum
<<Process config: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
pure function process_component_get_md5sum (component) result (md5)
type(string_t) :: md5
class(process_component_t), intent(in) :: component
md5 = component%config%get_md5sum () // component%md5sum_phs
end function process_component_get_md5sum
@ %def process_component_get_md5sum
@ Return the number of phase-space parameters.
<<Process config: process component: TBP>>=
procedure :: get_n_phs_par => process_component_get_n_phs_par
<<Process config: procedures>>=
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: procedures>>=
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: procedures>>=
elemental function process_component_get_nlo_type (component) result (nlo_type)
integer :: nlo_type
class(process_component_t), intent(in) :: component
nlo_type = component%config%get_nlo_type ()
end function process_component_get_nlo_type
@ %def process_component_get_nlo_type
@
<<Process config: process component: TBP>>=
procedure :: needs_mci_entry => process_component_needs_mci_entry
<<Process config: procedures>>=
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: procedures>>=
elemental function process_component_can_be_integrated (component) result (active)
logical :: active
class(process_component_t), intent(in) :: component
active = component%config%can_be_integrated ()
end function process_component_can_be_integrated
@ %def process_component_can_be_integrated
@
\subsection{Process terms}
For straightforward tree-level calculations, each process component
corresponds to a unique elementary interaction. However, in the case
of NLO calculations with subtraction terms, a process component may
split into several separate contributions to the scattering, which are
qualified by interactions with distinct kinematics and particle
content. We represent their configuration as [[process_term_t]]
objects, the actual instances will be introduced below as
[[term_instance_t]]. In any case, the process term contains an
elementary interaction with a definite quantum-number and momentum
content.
The index [[i_term_global]] identifies the term relative to the
process.
The index [[i_component]] identifies the process component which
generates this term, relative to the parent process.
The index [[i_term]] identifies the term relative to the process
component (not the process).
The [[data]] subobject holds all process constants.
The number of allowed flavor/helicity/color combinations is stored as
[[n_allowed]]. This is the total number of independent entries in the
density matrix. For each combination, the index of the flavor,
helicity, and color state is stored in the arrays [[flv]], [[hel]],
and [[col]], respectively.
The flag [[rearrange]] is true if we need to rearrange the particles of the
hard interaction, to obtain the effective parton state.
The interaction [[int]] holds the quantum state for the (resolved) hard
interaction, the parent-child relations of the particles, and their momenta.
The momenta are not filled yet; this is postponed to copies of [[int]] which
go into the process instances.
If recombination is in effect, we should allocate [[int_eff]] to describe the
rearranged partonic state.
This type is public only for use in a unit test.
<<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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_term_final (term)
class(process_term_t), intent(inout) :: term
call term%int%final ()
end subroutine process_term_final
@ %def process_term_final
@ Initialize the term. We copy the process constants from the [[core]]
object and set up the [[int]] hard interaction accordingly.
The [[alpha_s]] value is useful for writing external event records. This is
the constant value which may be overridden by a event-specific running value.
If the model does not contain the strong coupling, the value is zero.
The [[rearrange]] part is commented out; this or something equivalent
could become relevant for NLO algorithms.
<<Process config: process term: TBP>>=
procedure :: init => process_term_init
<<Process config: procedures>>=
subroutine process_term_init &
(term, i_term_global, i_component, i_term, core, model, &
nlo_type, use_beam_pol, subtraction_method, &
has_pdfs, n_emitters)
class(process_term_t), intent(inout), target :: term
integer, intent(in) :: i_term_global
integer, intent(in) :: i_component
integer, intent(in) :: i_term
class(prc_core_t), intent(inout) :: core
class(model_data_t), intent(in), target :: model
integer, intent(in), optional :: nlo_type
logical, intent(in), optional :: use_beam_pol
type(string_t), intent(in), optional :: subtraction_method
logical, intent(in), optional :: has_pdfs
integer, intent(in), optional :: n_emitters
class(modelpar_data_t), pointer :: alpha_s_ptr
logical :: use_internal_color
term%i_term_global = i_term_global
term%i_component = i_component
term%i_term = i_term
call core%get_constants (term%data, i_term)
alpha_s_ptr => model%get_par_data_ptr (var_str ("alphas"))
if (associated (alpha_s_ptr)) then
term%alpha_s = alpha_s_ptr%get_real ()
else
term%alpha_s = -1
end if
use_internal_color = .false.
if (present (subtraction_method)) &
use_internal_color = (char (subtraction_method) == 'omega') &
.or. (char (subtraction_method) == 'threshold')
call term%setup_interaction (core, model, nlo_type = nlo_type, &
pol_beams = use_beam_pol, use_internal_color = use_internal_color, &
has_pdfs = has_pdfs, n_emitters = n_emitters)
end subroutine process_term_init
@ %def process_term_init
@ We fetch the process constants which determine the quantum numbers and
use those to create the interaction. The interaction contains
incoming and outgoing particles, no virtuals. The incoming particles
are parents of the outgoing ones.
Keeping previous \whizard\ conventions, we invert the color assignment
(but not flavor or helicity) for the incoming particles. When the
color-flow square matrix is evaluated, this inversion is done again,
so in the color-flow sequence we get the color assignments of the
matrix element.
\textbf{Why are these four subtraction entries for structure-function
aware interactions?} Taking the soft or collinear limit of the real-emission
matrix element, the behavior of the parton energy fractions has to be
taken into account. In the pure real case, $x_\oplus$ and $x_\ominus$
are given by
\begin{equation*}
x_\oplus = \frac{\bar{x}_\oplus}{\sqrt{1-\xi}}
\sqrt{\frac{2 - \xi(1-y)}{2 - \xi(1+y)}},
\quad
x_\ominus = \frac{\bar{x}_\ominus}{\sqrt{1-\xi}}
\sqrt{\frac{2 - \xi(1+y)}{2 - \xi(1-y)}}.
\end{equation*}
In the soft limit, $\xi \to 0$, this yields $x_\oplus = \bar{x}_\oplus$
and $x_\ominus = \bar{x}_\ominus$. In the collinear limit, $y \to 1$,
it is $x_\oplus = \bar{x}_\oplus / (1 - \xi)$ and $x_\ominus = \bar{x}_\ominus$.
Likewise, in the anti-collinear limit $y \-o -1$, the inverse relation holds.
We therefore have to distinguish four cases with the PDF assignments
$f(x_\oplus) \cdot f(x_\ominus)$, $f(\bar{x}_\oplus) \cdot f(\bar{x}_\ominus)$,
$f\left(\bar{x}_\oplus / (1-\xi)\right) \cdot f(\bar{x}_\ominus)$ and
$f(\bar{x}_\oplus) \cdot f\left(\bar{x}_\ominus / (1-\xi)\right)$.
The [[n_emitters]] optional argument is provided by the caller if this term
requires spin-correlated matrix elements, and thus involves additional
subtractions.
<<Process config: process term: TBP>>=
procedure :: setup_interaction => process_term_setup_interaction
<<Process config: procedures>>=
subroutine process_term_setup_interaction (term, core, model, &
nlo_type, pol_beams, has_pdfs, use_internal_color, n_emitters)
class(process_term_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
class(model_data_t), intent(in), target :: model
logical, intent(in), optional :: pol_beams
logical, intent(in), optional :: has_pdfs
integer, intent(in), optional :: nlo_type
logical, intent(in), optional :: use_internal_color
integer, intent(in), optional :: n_emitters
integer :: n, n_tot
type(flavor_t), dimension(:), allocatable :: flv
type(color_t), dimension(:), allocatable :: col
type(helicity_t), dimension(:), allocatable :: hel
type(quantum_numbers_t), dimension(:), allocatable :: qn
logical :: is_pol, use_color
integer :: nlo_t, n_sub
is_pol = .false.; if (present (pol_beams)) is_pol = pol_beams
nlo_t = BORN; if (present (nlo_type)) nlo_t = nlo_type
n_tot = term%data%n_in + term%data%n_out
call count_number_of_states ()
term%n_allowed = n
call compute_n_sub (n_emitters, has_pdfs)
call fill_quantum_numbers ()
call term%int%basic_init &
(term%data%n_in, 0, term%data%n_out, set_relations = .true.)
select type (core)
class is (prc_blha_t)
call setup_states_blha_olp ()
type is (prc_threshold_t)
call setup_states_threshold ()
class is (prc_external_t)
call setup_states_other_prc_external ()
class default
call setup_states_omega ()
end select
call term%int%freeze ()
contains
subroutine count_number_of_states ()
integer :: f, h, c
n = 0
select type (core)
class is (prc_external_t)
do f = 1, term%data%n_flv
do h = 1, term%data%n_hel
do c = 1, term%data%n_col
n = n + 1
end do
end do
end do
class default !!! Omega and all test cores
do f = 1, term%data%n_flv
do h = 1, term%data%n_hel
do c = 1, term%data%n_col
if (core%is_allowed (term%i_term, f, h, c)) n = n + 1
end do
end do
end do
end select
end subroutine count_number_of_states
subroutine compute_n_sub (n_emitters, has_pdfs)
integer, intent(in), optional :: n_emitters
logical, intent(in), optional :: has_pdfs
logical :: can_have_sub
integer :: n_sub_color, n_sub_spin
use_color = .false.; if (present (use_internal_color)) &
use_color = use_internal_color
can_have_sub = nlo_t == NLO_VIRTUAL .or. &
(nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. &
nlo_t == NLO_MISMATCH
n_sub_color = 0; n_sub_spin = 0
if (can_have_sub) then
if (.not. use_color) n_sub_color = n_tot * (n_tot - 1) / 2
if (nlo_t == NLO_REAL) then
if (present (n_emitters)) then
n_sub_spin = 16 * n_emitters
end if
end if
end if
n_sub = n_sub_color + n_sub_spin
!!! For the virtual subtraction we also need the finite virtual contribution
!!! corresponding to the $\epsilon^0$-pole
if (nlo_t == NLO_VIRTUAL) n_sub = n_sub + 1
if (present (has_pdfs)) then
if (has_pdfs &
.and. ((nlo_t == NLO_REAL .and. can_have_sub) &
.or. nlo_t == NLO_DGLAP)) then
n_sub = n_sub + n_beam_structure_int
end if
end if
term%n_sub = n_sub
term%n_sub_color = n_sub_color
term%n_sub_spin = n_sub_spin
end subroutine compute_n_sub
subroutine fill_quantum_numbers ()
integer :: nn
logical :: can_have_sub
select type (core)
class is (prc_external_t)
can_have_sub = nlo_t == NLO_VIRTUAL .or. &
(nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. &
nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP
if (can_have_sub) then
nn = (n_sub + 1) * n
else
nn = n
end if
class default
nn = n
end select
allocate (term%flv (nn), term%col (nn), term%hel (nn))
allocate (flv (n_tot), col (n_tot), hel (n_tot))
allocate (qn (n_tot))
end subroutine fill_quantum_numbers
subroutine setup_states_blha_olp ()
integer :: s, f, c, h, i
i = 0
associate (data => term%data)
do s = 0, n_sub
do f = 1, data%n_flv
do h = 1, data%n_hel
do c = 1, data%n_col
i = i + 1
term%flv(i) = f
term%hel(i) = h
!!! Dummy-initialization of color
term%col(i) = c
call flv%init (data%flv_state (:,f), model)
call color_init_from_array (col, &
data%col_state(:,:,c), data%ghost_flag(:,c))
call col(1:data%n_in)%invert ()
if (is_pol) then
select type (core)
type is (prc_openloops_t)
call hel%init (data%hel_state (:,h))
call qn%init (flv, hel, col, s)
class default
call msg_fatal ("Polarized beams only supported by OpenLoops")
end select
else
call qn%init (flv, col, s)
end if
call qn%tag_hard_process ()
call term%int%add_state (qn)
end do
end do
end do
end do
end associate
end subroutine setup_states_blha_olp
subroutine setup_states_threshold ()
integer :: s, f, c, h, i
i = 0
n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1
associate (data => term%data)
do s = 0, n_sub
do f = 1, term%data%n_flv
do h = 1, data%n_hel
do c = 1, data%n_col
i = i + 1
term%flv(i) = f
term%hel(i) = h
!!! Dummy-initialization of color
term%col(i) = 1
call flv%init (term%data%flv_state (:,f), model)
if (is_pol) then
call hel%init (data%hel_state (:,h))
call qn%init (flv, hel, s)
else
call qn%init (flv, s)
end if
call qn%tag_hard_process ()
call term%int%add_state (qn)
end do
end do
end do
end do
end associate
end subroutine setup_states_threshold
subroutine setup_states_other_prc_external ()
integer :: s, f, i, c, h
if (is_pol) &
call msg_fatal ("Polarized beams only supported by OpenLoops")
i = 0
!!! n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1
associate (data => term%data)
do s = 0, n_sub
do f = 1, data%n_flv
do h = 1, data%n_hel
do c = 1, data%n_col
i = i + 1
term%flv(i) = f
term%hel(i) = h
!!! Dummy-initialization of color
term%col(i) = c
call flv%init (data%flv_state (:,f), model)
call color_init_from_array (col, &
data%col_state(:,:,c), data%ghost_flag(:,c))
call col(1:data%n_in)%invert ()
call qn%init (flv, col, s)
call qn%tag_hard_process ()
call term%int%add_state (qn)
end do
end do
end do
end do
end associate
end subroutine setup_states_other_prc_external
subroutine setup_states_omega ()
integer :: f, h, c, i
i = 0
associate (data => term%data)
do f = 1, data%n_flv
do h = 1, data%n_hel
do c = 1, data%n_col
if (core%is_allowed (term%i_term, f, h, c)) then
i = i + 1
term%flv(i) = f
term%hel(i) = h
term%col(i) = c
call flv%init (data%flv_state(:,f), model)
call color_init_from_array (col, &
data%col_state(:,:,c), &
data%ghost_flag(:,c))
call col(:data%n_in)%invert ()
call hel%init (data%hel_state(:,h))
call qn%init (flv, col, hel)
call qn%tag_hard_process ()
call term%int%add_state (qn)
end if
end do
end do
end do
end associate
end subroutine setup_states_omega
end subroutine process_term_setup_interaction
@ %def process_term_setup_interaction
@
<<Process config: process term: TBP>>=
procedure :: get_process_constants => process_term_get_process_constants
<<Process config: procedures>>=
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
use io_units
<<Standard module head>>
<<Process counter: public>>
<<Process counter: parameters>>
<<Process counter: types>>
contains
<<Process counter: procedures>>
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: procedures>>=
subroutine process_counter_write (object, unit)
class(process_counter_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
if (object%total > 0) then
write (u, "(1x,A)") "Call statistics (current run):"
write (u, "(3x,A,I0)") "total = ", object%total
write (u, "(3x,A,I0)") "failed kin. = ", object%failed_kinematics
write (u, "(3x,A,I0)") "failed cuts = ", object%failed_cuts
write (u, "(3x,A,I0)") "passed cuts = ", object%has_passed
write (u, "(3x,A,I0)") "evaluated = ", object%evaluated
else
write (u, "(1x,A)") "Call statistics (current run): [no calls]"
end if
end subroutine process_counter_write
@ %def process_counter_write
@ Reset. Just enforce default initialization.
<<Process counter: process counter: TBP>>=
procedure :: reset => process_counter_reset
<<Process counter: procedures>>=
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: procedures>>=
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 debug>>
use io_units
use diagnostics
use physics_defs
use md5
use cputime
use rng_base
use mci_base
use variables
use integration_results
use process_libraries
use phs_base
use process_counter
use process_config
<<Standard module head>>
<<Process mci: public>>
<<Process mci: parameters>>
<<Process mci: types>>
contains
<<Process mci: procedures>>
end module process_mci
@ %def process_mci
\subsection{Process MCI entry}
The [[process_mci_entry_t]] block contains, for each process component that is
integrated independently, the configuration data for its MC input parameters.
Each input parameter set is handled by a [[mci_t]] integrator.
The MC input parameter set is broken down into the parameters required by the
structure-function chain and the parameters required by the phase space of the
elementary process.
The MD5 sum collects all information about the associated processes
that may affect the integration. It does not contain the MCI object
itself or integration results.
MC integration is organized in passes. Each pass may consist of
several iterations, and for each iteration there is a number of
calls. We store explicitly the values that apply to the current
pass. Previous values are archived in the [[results]] object.
The [[counter]] receives the counter statistics from the associated
process instance, for diagnostics.
The [[results]] object records results, broken down in passes and iterations.
<<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
logical :: combined_integration = .false.
integer :: real_partition_type = REAL_FULL
integer :: associated_real_component = 0
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: procedures>>=
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: procedures>>=
subroutine process_mci_entry_write (object, unit, pacify)
class(process_mci_entry_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacify
integer :: u
u = given_output_unit (unit)
write (u, "(3x,A,I0)") "Associated components = ", object%i_component
write (u, "(3x,A,I0)") "MC input parameters = ", object%n_par
write (u, "(3x,A,I0)") "MC parameters (SF) = ", object%n_par_sf
write (u, "(3x,A,I0)") "MC parameters (PHS) = ", object%n_par_phs
if (object%pass > 0) then
write (u, "(3x,A,I0)") "Current pass = ", object%pass
write (u, "(3x,A,I0)") "Number of iterations = ", object%n_it
write (u, "(3x,A,I0)") "Number of calls = ", object%n_calls
end if
if (object%md5sum /= "") then
write (u, "(3x,A,A,A)") "MD5 sum (components) = '", object%md5sum, "'"
end if
if (allocated (object%mci)) then
call object%mci%write (u)
end if
call object%counter%write (u)
if (object%results%exist ()) then
call object%results%write (u, suppress = pacify)
call object%results%write_chain_weights (u)
end if
end subroutine process_mci_entry_write
@ %def process_mci_entry_write
@ Configure the MCI entry. This is intent(inout) since some specific settings
may be done before this. The actual [[mci_t]] object is an instance of the
[[mci_template]] argument, which determines the concrete types.
In a unit-test context, the [[mci_template]] argument may be unallocated.
We obtain the number of channels and the number of parameters, separately for
the structure-function chain and for the associated process component. We
assume that the phase-space object has already been configured.
We assume that there is only one process component directly associated with a
MCI entry.
<<Process mci: process mci entry: TBP>>=
procedure :: configure => process_mci_entry_configure
<<Process mci: procedures>>=
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: procedures>>=
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
n = get_n_components (mci_entry%real_partition_type)
allocate (i_list (n))
if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
"mci_entry%real_partition_type", mci_entry%real_partition_type)
select case (mci_entry%real_partition_type)
case (REAL_FULL)
i_list = component_config%get_association_list ()
allocate (mci_entry%i_component (size (i_list)))
mci_entry%i_component = i_list
case (REAL_SINGULAR)
i_list = component_config%get_association_list (ASSOCIATED_REAL_FIN)
allocate (mci_entry%i_component (size(i_list)))
mci_entry%i_component = i_list
case (REAL_FINITE)
allocate (mci_entry%i_component (1))
mci_entry%i_component(1) = &
component_config%get_associated_real_fin () + i_rfin_offset
i_rfin_offset = i_rfin_offset + 1
end select
else
allocate (mci_entry%i_component (1))
mci_entry%i_component(1) = i_component
end if
contains
function get_n_components (damping_type) result (n_components)
integer :: n_components
integer, intent(in) :: damping_type
select case (damping_type)
case (REAL_FULL)
n_components = size (component_config%get_association_list ())
case (REAL_SINGULAR)
n_components = size (component_config%get_association_list &
(ASSOCIATED_REAL_FIN))
end select
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
@
<<Process mci: process mci entry: TBP>>=
procedure :: set_associated_real_component &
=> process_mci_entry_set_associated_real_component
<<Process mci: procedures>>=
subroutine process_mci_entry_set_associated_real_component (mci_entry, i)
class(process_mci_entry_t), intent(inout) :: mci_entry
integer, intent(in) :: i
mci_entry%associated_real_component = i
end subroutine process_mci_entry_set_associated_real_component
@ %def process_mci_entry_set_associated_real_component
@ Set some additional parameters.
<<Process mci: process mci entry: TBP>>=
procedure :: set_parameters => process_mci_entry_set_parameters
<<Process mci: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_mci_entry_integrate (mci_entry, mci_instance, &
mci_sampler, n_it, n_calls, &
adapt_grids, adapt_weights, final, pacify, &
nlo_type)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_instance_t), intent(inout) :: mci_instance
class(mci_sampler_t), intent(inout) :: mci_sampler
integer, intent(in) :: n_it
integer, intent(in) :: n_calls
logical, intent(in), optional :: adapt_grids
logical, intent(in), optional :: adapt_weights
logical, intent(in), optional :: final, pacify
integer, intent(in), optional :: nlo_type
integer :: u_log
u_log = logfile_unit ()
mci_entry%pass = mci_entry%pass + 1
mci_entry%n_it = n_it
mci_entry%n_calls = n_calls
if (mci_entry%pass == 1) &
call mci_entry%mci%startup_message (n_calls = n_calls)
call mci_entry%mci%set_timer (active = mci_entry%activate_timer)
call mci_entry%results%display_init (screen = .true., unit = u_log)
call mci_entry%results%new_pass ()
if (present (nlo_type)) then
select case (nlo_type)
case (NLO_VIRTUAL, NLO_REAL, NLO_MISMATCH, NLO_DGLAP)
mci_instance%negative_weights = .true.
end select
end if
call mci_entry%mci%add_pass (adapt_grids, adapt_weights, final)
call mci_entry%mci%start_timer ()
call mci_entry%mci%integrate (mci_instance, mci_sampler, n_it, &
n_calls, mci_entry%results, pacify = pacify)
call mci_entry%mci%stop_timer ()
if (signal_is_pending ()) return
end subroutine process_mci_entry_integrate
subroutine process_mci_entry_final_integration (mci_entry)
class(process_mci_entry_t), intent(inout) :: mci_entry
call mci_entry%results%display_final ()
call mci_entry%time_message ()
end subroutine process_mci_entry_final_integration
@ %def process_mci_entry_integrate
@ %def process_mci_entry_final_integration
@ If appropriate, issue an informative message about the expected time
for an event sample.
<<Process mci: process mci entry: TBP>>=
procedure :: get_time => process_mci_entry_get_time
procedure :: time_message => process_mci_entry_time_message
<<Process mci: procedures>>=
subroutine process_mci_entry_get_time (mci_entry, time, sample)
class(process_mci_entry_t), intent(in) :: mci_entry
type(time_t), intent(out) :: time
integer, intent(in) :: sample
real(default) :: time_last_pass, efficiency, calls
time_last_pass = mci_entry%mci%get_time ()
calls = mci_entry%results%get_n_calls ()
efficiency = mci_entry%mci%get_efficiency ()
if (time_last_pass > 0 .and. calls > 0 .and. efficiency > 0) then
time = nint (time_last_pass / calls / efficiency * sample)
end if
end subroutine process_mci_entry_get_time
subroutine process_mci_entry_time_message (mci_entry)
class(process_mci_entry_t), intent(in) :: mci_entry
type(time_t) :: time
integer :: sample
sample = 10000
call mci_entry%get_time (time, sample)
if (time%is_known ()) then
call msg_message ("Time estimate for generating 10000 events: " &
// char (time%to_string_dhms ()))
end if
end subroutine process_mci_entry_time_message
@ %def process_mci_entry_time_message
@ Prepare event generation. (For the test integrator, this does nothing. It
is relevant for the VAMP integrator.)
<<Process mci: process mci entry: TBP>>=
procedure :: prepare_simulation => process_mci_entry_prepare_simulation
<<Process mci: procedures>>=
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: procedures>>=
subroutine process_mci_entry_generate_weighted_event (mci_entry, &
mci_instance, mci_sampler, keep_failed)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_instance_t), intent(inout) :: mci_instance
class(mci_sampler_t), intent(inout) :: mci_sampler
logical, intent(in) :: keep_failed
logical :: generate_new
generate_new = .true.
call mci_instance%reset_n_event_dropped ()
REJECTION: do while (generate_new)
call mci_entry%mci%generate_weighted_event (mci_instance, mci_sampler)
if (signal_is_pending ()) return
if (.not. mci_sampler%is_valid()) then
if (keep_failed) then
generate_new = .false.
else
call mci_instance%record_event_dropped ()
generate_new = .true.
end if
else
generate_new = .false.
end if
end do REJECTION
end subroutine process_mci_entry_generate_weighted_event
subroutine process_mci_entry_generate_unweighted_event (mci_entry, mci_instance, mci_sampler)
class(process_mci_entry_t), intent(inout) :: mci_entry
class(mci_instance_t), intent(inout) :: mci_instance
class(mci_sampler_t), intent(inout) :: mci_sampler
call mci_entry%mci%generate_unweighted_event (mci_instance, mci_sampler)
end subroutine process_mci_entry_generate_unweighted_event
@ %def process_mci_entry_generate_weighted_event
@ %def process_mci_entry_generate_unweighted_event
@ Extract results.
<<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: procedures>>=
function process_mci_entry_has_integral (mci_entry) result (flag)
class(process_mci_entry_t), intent(in) :: mci_entry
logical :: flag
flag = mci_entry%results%exist ()
end function process_mci_entry_has_integral
function process_mci_entry_get_integral (mci_entry) result (integral)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: integral
integral = mci_entry%results%get_integral ()
end function process_mci_entry_get_integral
function process_mci_entry_get_error (mci_entry) result (error)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: error
error = mci_entry%results%get_error ()
end function process_mci_entry_get_error
function process_mci_entry_get_accuracy (mci_entry) result (accuracy)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: accuracy
accuracy = mci_entry%results%get_accuracy ()
end function process_mci_entry_get_accuracy
function process_mci_entry_get_chi2 (mci_entry) result (chi2)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: chi2
chi2 = mci_entry%results%get_chi2 ()
end function process_mci_entry_get_chi2
function process_mci_entry_get_efficiency (mci_entry) result (efficiency)
class(process_mci_entry_t), intent(in) :: mci_entry
real(default) :: efficiency
efficiency = mci_entry%results%get_efficiency ()
end function process_mci_entry_get_efficiency
@ %def process_mci_entry_get_integral process_mci_entry_get_error
@ %def process_mci_entry_get_accuracy process_mci_entry_get_chi2
@ %def process_mci_entry_get_efficiency
@ Return the MCI checksum. This may be the one used for
configuration, but may also incorporate results, if they change the
state of the integrator (adaptation).
<<Process mci: process mci entry: TBP>>=
procedure :: get_md5sum => process_mci_entry_get_md5sum
<<Process mci: procedures>>=
pure function process_mci_entry_get_md5sum (entry) result (md5sum)
class(process_mci_entry_t), intent(in) :: entry
character(32) :: md5sum
md5sum = entry%mci%get_md5sum ()
end function process_mci_entry_get_md5sum
@ %def process_mci_entry_get_md5sum
@
\subsection{MC parameter set and MCI instance}
For each process component that is associated with a multi-channel integration
(MCI) object, the [[mci_work_t]] object contains the currently active
parameter set. It also holds the implementation of the [[mci_instance_t]]
that the integrator needs for doing its work.
<<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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine mci_work_set (mci_work, x)
class(mci_work_t), intent(inout) :: mci_work
real(default), dimension(:), intent(in) :: x
mci_work%x = x
end subroutine mci_work_set
subroutine mci_work_set_x_strfun (mci_work, x)
class(mci_work_t), intent(inout) :: mci_work
real(default), dimension(:), intent(in) :: x
mci_work%x(1 : mci_work%config%n_par_sf) = x
end subroutine mci_work_set_x_strfun
subroutine mci_work_set_x_process (mci_work, x)
class(mci_work_t), intent(inout) :: mci_work
real(default), dimension(:), intent(in) :: x
mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par) = x
end subroutine mci_work_set_x_process
@ %def mci_work_set
@ %def mci_work_set_x_strfun
@ %def mci_work_set_x_process
@ Return the array of active components, i.e., those that correspond
to the currently selected MC parameter set.
<<Process mci: mci work: TBP>>=
procedure :: get_active_components => mci_work_get_active_components
<<Process mci: procedures>>=
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: procedures>>=
pure function mci_work_get_x_strfun (mci_work) result (x)
class(mci_work_t), intent(in) :: mci_work
real(default), dimension(mci_work%config%n_par_sf) :: x
x = mci_work%x(1 : mci_work%config%n_par_sf)
end function mci_work_get_x_strfun
pure function mci_work_get_x_process (mci_work) result (x)
class(mci_work_t), intent(in) :: mci_work
real(default), dimension(mci_work%config%n_par_phs) :: x
x = mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par)
end function mci_work_get_x_process
@ %def mci_work_get_x_strfun
@ %def mci_work_get_x_process
@ Initialize and finalize event generation for the specified MCI
entry. This also resets the counter.
<<Process mci: mci work: TBP>>=
procedure :: init_simulation => mci_work_init_simulation
procedure :: final_simulation => mci_work_final_simulation
<<Process mci: procedures>>=
subroutine mci_work_init_simulation (mci_work, safety_factor, keep_failed_events)
class(mci_work_t), intent(inout) :: mci_work
real(default), intent(in), optional :: safety_factor
logical, intent(in), optional :: keep_failed_events
call mci_work%mci%init_simulation (safety_factor)
call mci_work%counter%reset ()
if (present (keep_failed_events)) &
mci_work%keep_failed_events = keep_failed_events
end subroutine mci_work_init_simulation
subroutine mci_work_final_simulation (mci_work)
class(mci_work_t), intent(inout) :: mci_work
call mci_work%mci%final_simulation ()
end subroutine mci_work_final_simulation
@ %def mci_work_init_simulation
@ %def mci_work_final_simulation
@ Counter.
<<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: procedures>>=
subroutine mci_work_reset_counter (mci_work)
class(mci_work_t), intent(inout) :: mci_work
call mci_work%counter%reset ()
end subroutine mci_work_reset_counter
subroutine mci_work_record_call (mci_work, status)
class(mci_work_t), intent(inout) :: mci_work
integer, intent(in) :: status
call mci_work%counter%record (status)
end subroutine mci_work_record_call
pure function mci_work_get_counter (mci_work) result (counter)
class(mci_work_t), intent(in) :: mci_work
type(process_counter_t) :: counter
counter = mci_work%counter
end function mci_work_get_counter
@ %def mci_work_reset_counter
@ %def mci_work_record_call
@ %def mci_work_get_counter
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Process component manager}
<<[[pcm.f90]]>>=
<<File header>>
module pcm
<<Use kinds>>
<<Use strings>>
<<Use debug>>
use constants, only: zero, two
use diagnostics
use lorentz
use io_units, only: free_unit
use os_interface
use process_constants, only: process_constants_t
use physics_defs
use model_data, only: model_data_t
use models, only: model_t
use interactions, only: interaction_t
use quantum_numbers, only: quantum_numbers_t, quantum_numbers_mask_t
use flavors, only: flavor_t
use variables, only: var_list_t
use nlo_data, only: nlo_settings_t
use mci_base, only: mci_t
use phs_base, only: phs_config_t
use mappings, only: mapping_defaults_t
use phs_forests, only: phs_parameters_t
use phs_fks, only: isr_kinematics_t, real_kinematics_t
use phs_fks, only: phs_identifier_t
use dispatch_fks, only: dispatch_fks_s
use fks_regions, only: region_data_t
use nlo_data, only: fks_template_t
use phs_fks, only: phs_fks_generator_t
use phs_fks, only: dalitz_plot_t
use phs_fks, only: phs_fks_config_t, get_filtered_resonance_histories
use dispatch_phase_space, only: dispatch_phs
use process_libraries, only: process_component_def_t
use real_subtraction, only: real_subtraction_t, soft_mismatch_t
use real_subtraction, only: FIXED_ORDER_EVENTS, POWHEG
use real_subtraction, only: real_partition_t, powheg_damping_simple_t
use real_subtraction, only: real_partition_fixed_order_t
use virtual, only: virtual_t
use dglap_remnant, only: dglap_remnant_t
use prc_threshold, only: threshold_def_t
use resonances, only: resonance_history_t, resonance_history_set_t
use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES
use blha_config, only: blha_master_t
use blha_olp_interfaces, only: prc_blha_t
use pcm_base
use process_config
use process_mci, only: process_mci_entry_t
use process_mci, only: REAL_SINGULAR, REAL_FINITE
<<Standard module head>>
<<Pcm: public>>
<<Pcm: types>>
contains
<<Pcm: procedures>>
end module pcm
@ %def pcm
@
\subsection{Default process component manager}
This is the configuration object which has the duty of allocating the
corresponding instance. The default version is trivial.
<<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
<<Pcm: pcm default: TBP>>=
procedure :: allocate_instance => pcm_default_allocate_instance
<<Pcm: procedures>>=
subroutine pcm_default_allocate_instance (pcm, instance)
class(pcm_default_t), intent(in) :: pcm
class(pcm_instance_t), intent(inout), allocatable :: instance
allocate (pcm_instance_default_t :: instance)
end subroutine pcm_default_allocate_instance
@ %def pcm_default_allocate_instance
@
Finalizer: apply to core manager.
<<Pcm: pcm default: TBP>>=
procedure :: final => pcm_default_final
<<Pcm: procedures>>=
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: procedures>>=
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: procedures>>=
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_instance_t) :: pcm_instance_default_t
contains
<<Pcm: pcm instance default: TBP>>
end type pcm_instance_default_t
@ %def pcm_instance_default_t
@
<<Pcm: pcm instance default: TBP>>=
procedure :: final => pcm_instance_default_final
<<Pcm: procedures>>=
subroutine pcm_instance_default_final (pcm_instance)
class(pcm_instance_default_t), intent(inout) :: pcm_instance
end subroutine pcm_instance_default_final
@ %def pcm_instance_default_final
@
\subsection{Implementations for the default manager}
Categorize components. Nothing to do here, all components are of Born type.
<<Pcm: pcm default: TBP>>=
procedure :: categorize_components => pcm_default_categorize_components
<<Pcm: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine pcm_default_prepare_any_external_code &
(pcm, core_entry, i_core, libname, model, var_list)
class(pcm_default_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
integer, intent(in) :: i_core
type(string_t), intent(in) :: libname
type(model_data_t), intent(in), target :: model
type(var_list_t), intent(in) :: var_list
if (core_entry%active) then
associate (core => core_entry%core)
if (core%needs_external_code ()) then
call core%prepare_external_code &
(core%data%flv_state, &
var_list, pcm%os_data, libname, model, i_core, .false.)
end if
end associate
end if
end subroutine pcm_default_prepare_any_external_code
@ %def pcm_default_prepare_any_external_code
@ Allocate and configure the BLHA record for a specific core, assuming that
the core type requires it. In the default case, this is a Born
configuration.
<<Pcm: pcm default: TBP>>=
procedure :: setup_blha => pcm_default_setup_blha
<<Pcm: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine pcm_default_set_blha_methods (pcm, blha_master, var_list)
class(pcm_default_t), intent(in) :: pcm
type(blha_master_t), intent(inout) :: blha_master
type(var_list_t), intent(in) :: var_list
call blha_master%set_methods (.false., var_list)
end subroutine pcm_default_set_blha_methods
@ %def pcm_default_set_blha_methods
@ Produce the LO and NLO flavor-state tables (as far as available), as
appropriate for BLHA configuration.
The default version looks at the first process core only, to get the Born
data. (Multiple cores are thus unsupported.) The NLO flavor table is left
unallocated.
<<Pcm: pcm default: TBP>>=
procedure :: get_blha_flv_states => pcm_default_get_blha_flv_states
<<Pcm: procedures>>=
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: procedures>>=
subroutine pcm_default_setup_mci (pcm, mci_entry)
class(pcm_default_t), intent(inout) :: pcm
type(process_mci_entry_t), &
dimension(:), allocatable, intent(out) :: mci_entry
class(mci_t), allocatable :: mci_template
integer :: i, i_mci
pcm%n_mci = count (pcm%component_active)
allocate (pcm%i_mci (pcm%n_components), source = 0)
i_mci = 0
do i = 1, pcm%n_components
if (pcm%component_active(i)) then
i_mci = i_mci + 1
pcm%i_mci(i) = i_mci
end if
end do
allocate (mci_entry (pcm%n_mci))
end subroutine pcm_default_setup_mci
subroutine pcm_default_call_dispatch_mci (pcm, &
dispatch_mci, var_list, process_id, mci_template)
class(pcm_default_t), intent(inout) :: pcm
procedure(dispatch_mci_proc) :: dispatch_mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
class(mci_t), allocatable, intent(out) :: mci_template
call dispatch_mci (mci_template, var_list, process_id)
end subroutine pcm_default_call_dispatch_mci
@ %def pcm_default_setup_mci
@ %def pcm_default_call_dispatch_mci
@ Nothing left to do for the default algorithm.
<<Pcm: pcm default: TBP>>=
procedure :: complete_setup => pcm_default_complete_setup
<<Pcm: procedures>>=
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: procedures>>=
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.
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: procedures>>=
subroutine pcm_nlo_init (pcm, env, meta)
class(pcm_nlo_t), intent(out) :: pcm
type(process_metadata_t), intent(in) :: meta
type(process_environment_t), intent(in) :: env
type(var_list_t), pointer :: var_list
type(fks_template_t) :: fks_template
pcm%id = meta%id
pcm%has_pdfs = env%has_pdfs ()
var_list => env%get_var_list_ptr ()
call dispatch_fks_s (fks_template, var_list)
call pcm%settings%init (var_list, fks_template)
pcm%combined_integration = &
var_list%get_lval (var_str ('?combined_nlo_integration'))
pcm%use_real_partition = &
var_list%get_lval (var_str ("?nlo_use_real_partition"))
pcm%real_partition_scale = &
var_list%get_rval (var_str ("real_partition_scale"))
pcm%vis_fks_regions = &
var_list%get_lval (var_str ("?vis_fks_regions"))
call pcm%set_blha_defaults &
(env%has_polarized_beams (), env%get_var_list_ptr ())
pcm%os_data = env%get_os_data ()
end subroutine pcm_nlo_init
@ %def pcm_nlo_init
@ Init/rewrite NLO settings without the FKS template.
<<Pcm: pcm nlo: TBP>>=
procedure :: init_nlo_settings => pcm_nlo_init_nlo_settings
<<Pcm: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine pcm_nlo_init_phs_config &
(pcm, phs_entry, meta, env, phs_par, mapping_defs)
class(pcm_nlo_t), intent(inout) :: pcm
type(process_phs_config_t), &
dimension(:), allocatable, intent(out) :: phs_entry
type(process_metadata_t), intent(in) :: meta
type(process_environment_t), intent(in) :: env
type(mapping_defaults_t), intent(in) :: mapping_defs
type(phs_parameters_t), intent(in) :: phs_par
integer :: i
logical :: first_real_component
allocate (phs_entry (2))
call dispatch_phs (phs_entry(1)%phs_config, &
env%get_var_list_ptr (), &
env%get_os_data (), &
meta%id, &
mapping_defs, phs_par, &
var_str ("wood"))
call dispatch_phs (phs_entry(2)%phs_config, &
env%get_var_list_ptr (), &
env%get_os_data (), &
meta%id, &
mapping_defs, phs_par, &
var_str ("fks"))
allocate (pcm%i_phs_config (pcm%n_components), source=0)
first_real_component = .true.
do i = 1, pcm%n_components
select case (pcm%nlo_type(i))
case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION)
pcm%i_phs_config(i) = 1
case (NLO_REAL)
if (first_real_component) then
pcm%i_phs_config(i) = 2
if (pcm%use_real_partition) first_real_component = .false.
else
pcm%i_phs_config(i) = 1
end if
case (NLO_MISMATCH, NLO_DGLAP, GKS)
pcm%i_phs_config(i) = 2
end select
end do
end subroutine pcm_nlo_init_phs_config
@ %def pcm_nlo_init_phs_config
@
\subsubsection{Core management}
Allocate the core (matrix-element interface) objects that we will need for
evaluation. Every component gets an associated core, except for the
real-finite and mismatch components (if any). Those components are associated
with their previous corresponding real-singular and subtraction cores,
respectively.
After cores are allocated, configure the region-data block that is maintained
by the NLO process-component manager.
<<Pcm: pcm nlo: TBP>>=
procedure :: allocate_cores => pcm_nlo_allocate_cores
<<Pcm: procedures>>=
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: procedures>>=
subroutine pcm_nlo_prepare_any_external_code &
(pcm, core_entry, i_core, libname, model, var_list)
class(pcm_nlo_t), intent(in) :: pcm
type(core_entry_t), intent(inout) :: core_entry
integer, intent(in) :: i_core
type(string_t), intent(in) :: libname
type(model_data_t), intent(in), target :: model
type(var_list_t), intent(in) :: var_list
integer, dimension(:,:), allocatable :: flv_born, flv_real
integer :: i
call pcm%region_data%get_all_flv_states (flv_born, flv_real)
if (core_entry%active) then
associate (core => core_entry%core)
if (core%needs_external_code ()) then
select case (pcm%nlo_type (core_entry%i_component))
case default
call core%data%set_flv_state (flv_born)
case (NLO_REAL)
call core%data%set_flv_state (flv_real)
end select
call core%prepare_external_code &
(core%data%flv_state, &
var_list, pcm%os_data, libname, model, i_core, .true.)
end if
end associate
end if
end subroutine pcm_nlo_prepare_any_external_code
@ %def pcm_nlo_prepare_any_external_code
@ Allocate and configure the BLHA record for a specific core, assuming that
the core type requires it. The configuration depends on the NLO type of the
core.
<<Pcm: pcm nlo: TBP>>=
procedure :: setup_blha => pcm_nlo_setup_blha
<<Pcm: procedures>>=
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: procedures>>=
subroutine pcm_nlo_complete_setup (pcm, core_entry, component, model)
class(pcm_nlo_t), intent(inout) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
type(process_component_t), dimension(:), intent(inout) :: component
type(model_t), intent(in), target :: model
integer :: i
call pcm%handle_threshold_core (core_entry)
call pcm%setup_region_data &
(core_entry, component(pcm%i_real)%phs_config, model)
call pcm%setup_real_partition ()
end subroutine pcm_nlo_complete_setup
@ %def pcm_nlo_complete_setup
@ Apply the BLHA configuration to a core object, using the region data from
[[pcm]] for determining the particle content.
<<Pcm: pcm nlo: TBP>>=
procedure :: prepare_blha_core => pcm_nlo_prepare_blha_core
<<Pcm: procedures>>=
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: procedures>>=
subroutine pcm_nlo_set_blha_methods (pcm, blha_master, var_list)
class(pcm_nlo_t), intent(in) :: pcm
type(blha_master_t), intent(inout) :: blha_master
type(var_list_t), intent(in) :: var_list
call blha_master%set_methods (.true., var_list)
end subroutine pcm_nlo_set_blha_methods
@ %def pcm_nlo_set_blha_methods
@ Produce the LO and NLO flavor-state tables (as far as available), as
appropriate for BLHA configuration.
The NLO version copies the tables from the region data inside [[pcm]]. The
core array is not needed.
<<Pcm: pcm nlo: TBP>>=
procedure :: get_blha_flv_states => pcm_nlo_get_blha_flv_states
<<Pcm: procedures>>=
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: procedures>>=
subroutine pcm_nlo_setup_mci (pcm, mci_entry)
class(pcm_nlo_t), intent(inout) :: pcm
type(process_mci_entry_t), &
dimension(:), allocatable, intent(out) :: mci_entry
class(mci_t), allocatable :: mci_template
integer :: i, i_mci
if (pcm%combined_integration) then
pcm%n_mci = 1 &
+ count (pcm%component_active(:) &
& .and. pcm%component_type(:) == COMP_REAL_FIN)
allocate (pcm%i_mci (pcm%n_components), source = 0)
do i = 1, pcm%n_components
if (pcm%component_active(i)) then
select case (pcm%component_type(i))
case (COMP_MASTER)
pcm%i_mci(i) = 1
case (COMP_REAL_FIN)
pcm%i_mci(i) = 2
end select
end if
end do
else
pcm%n_mci = count (pcm%component_active(:) &
& .and. pcm%nlo_type(:) /= NLO_SUBTRACTION)
allocate (pcm%i_mci (pcm%n_components), source = 0)
i_mci = 0
do i = 1, pcm%n_components
if (pcm%component_active(i)) then
select case (pcm%nlo_type(i))
case default
i_mci = i_mci + 1
pcm%i_mci(i) = i_mci
case (NLO_SUBTRACTION)
end select
end if
end do
end if
allocate (mci_entry (pcm%n_mci))
mci_entry(:)%combined_integration = pcm%combined_integration
if (pcm%use_real_partition) then
do i = 1, pcm%n_components
i_mci = pcm%i_mci(i)
if (i_mci > 0) then
select case (pcm%component_type(i))
case (COMP_REAL_FIN)
mci_entry(i_mci)%real_partition_type = REAL_FINITE
case default
mci_entry(i_mci)%real_partition_type = REAL_SINGULAR
end select
end if
end do
end if
end subroutine pcm_nlo_setup_mci
subroutine pcm_nlo_call_dispatch_mci (pcm, &
dispatch_mci, var_list, process_id, mci_template)
class(pcm_nlo_t), intent(inout) :: pcm
procedure(dispatch_mci_proc) :: dispatch_mci
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: process_id
class(mci_t), allocatable, intent(out) :: mci_template
call dispatch_mci (mci_template, var_list, process_id, is_nlo = .true.)
end subroutine pcm_nlo_call_dispatch_mci
@ %def pcm_nlo_setup_mci
@ %def pcm_nlo_call_dispatch_mci
@ Check for a threshold core and adjust the configuration accordingly, before
singular region data are considered.
<<Pcm: pcm nlo: TBP>>=
procedure :: handle_threshold_core => pcm_nlo_handle_threshold_core
<<Pcm: procedures>>=
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: procedures>>=
subroutine pcm_nlo_setup_region_data (pcm, core_entry, phs_config, model)
class(pcm_nlo_t), intent(inout) :: pcm
type(core_entry_t), dimension(:), intent(in) :: core_entry
class(phs_config_t), intent(inout) :: phs_config
type(model_t), intent(in), target :: model
type(process_constants_t) :: data_born, data_real
integer, dimension (:,:), allocatable :: flavor_born, flavor_real
type(resonance_history_t), dimension(:), allocatable :: resonance_histories
type(var_list_t), pointer :: var_list
logical :: success
data_born = core_entry(pcm%i_core(pcm%i_born))%core%data
data_real = core_entry(pcm%i_core(pcm%i_real))%core%data
call data_born%get_flv_state (flavor_born)
call data_real%get_flv_state (flavor_real)
call pcm%region_data%init &
(data_born%n_in, model, flavor_born, flavor_real, &
pcm%settings%nlo_correction_type)
associate (template => pcm%settings%fks_template)
if (template%mapping_type == FKS_RESONANCES) then
select type (phs_config)
type is (phs_fks_config_t)
call get_filtered_resonance_histories (phs_config, &
data_born%n_in, flavor_born, model, &
template%excluded_resonances, &
resonance_histories, success)
end select
if (.not. success) template%mapping_type = FKS_DEFAULT
end if
call pcm%region_data%setup_fks_mappings (template, data_born%n_in)
!!! Check again, mapping_type might have changed
if (template%mapping_type == FKS_RESONANCES) then
call pcm%region_data%set_resonance_mappings (resonance_histories)
call pcm%region_data%init_resonance_information ()
pcm%settings%use_resonance_mappings = .true.
end if
end associate
if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
call pcm%region_data%set_isr_pseudo_regions ()
call pcm%region_data%split_up_interference_regions_for_threshold ()
end if
call pcm%region_data%compute_number_of_phase_spaces ()
call pcm%region_data%set_i_phs_to_i_con ()
call pcm%region_data%write_to_file &
(pcm%id, pcm%vis_fks_regions, pcm%os_data)
if (debug_active (D_SUBTRACTION)) &
call pcm%region_data%check_consistency (.true.)
end subroutine pcm_nlo_setup_region_data
@ %def pcm_nlo_setup_region_data
@ After region data are set up, we allocate and configure the
[[real_partition]] objects, if requested.
<<Pcm: pcm nlo: TBP>>=
procedure :: setup_real_partition => pcm_nlo_setup_real_partition
<<Pcm: 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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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
@
<<Pcm: pcm nlo: TBP>>=
procedure :: allocate_instance => pcm_nlo_allocate_instance
<<Pcm: procedures>>=
subroutine pcm_nlo_allocate_instance (pcm, instance)
class(pcm_nlo_t), intent(in) :: pcm
class(pcm_instance_t), intent(inout), allocatable :: instance
allocate (pcm_instance_nlo_t :: instance)
end subroutine pcm_nlo_allocate_instance
@ %def pcm_nlo_allocate_instance
@
<<Pcm: pcm nlo: TBP>>=
procedure :: init_qn => pcm_nlo_init_qn
<<Pcm: procedures>>=
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
@
<<Pcm: pcm nlo: TBP>>=
procedure :: allocate_ps_matching => pcm_nlo_allocate_ps_matching
<<Pcm: 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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine pcm_nlo_setup_phs_generator (pcm, pcm_instance, generator, &
sqrts, mode, singular_jacobian)
class(pcm_nlo_t), intent(in) :: pcm
type(phs_fks_generator_t), intent(inout) :: generator
type(pcm_instance_nlo_t), intent(in), target :: pcm_instance
real(default), intent(in) :: sqrts
integer, intent(in), optional:: mode
logical, intent(in), optional :: singular_jacobian
logical :: yorn
yorn = .false.; if (present (singular_jacobian)) yorn = singular_jacobian
call generator%connect_kinematics (pcm_instance%isr_kinematics, &
pcm_instance%real_kinematics, pcm%has_massive_emitter ())
generator%n_in = pcm%region_data%n_in
call generator%set_sqrts_hat (sqrts)
call generator%set_emitters (pcm%region_data%emitters)
call generator%setup_masses (pcm%region_data%n_legs_born)
generator%is_massive = pcm%get_mass_info (1)
generator%singular_jacobian = yorn
if (present (mode)) generator%mode = mode
end subroutine pcm_nlo_setup_phs_generator
@ %def pcm_nlo_setup_phs_generator
@
<<Pcm: pcm nlo: TBP>>=
procedure :: final => pcm_nlo_final
<<Pcm: procedures>>=
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: procedures>>=
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_instance_nlo_t
<<Pcm: types>>=
type, extends (pcm_instance_t) :: pcm_instance_nlo_t
logical :: use_internal_color_correlation = .true.
type(real_kinematics_t), pointer :: real_kinematics => null ()
type(isr_kinematics_t), pointer :: isr_kinematics => null ()
type(real_subtraction_t) :: real_sub
type(virtual_t) :: virtual
type(soft_mismatch_t) :: soft_mismatch
type(dglap_remnant_t) :: dglap_remnant
integer, dimension(:), allocatable :: i_mci_to_real_component
contains
<<Pcm: pcm instance: TBP>>
end type pcm_instance_nlo_t
@ %def pcm_instance_nlo_t
@
<<Pcm: pcm instance: TBP>>=
procedure :: set_radiation_event => pcm_instance_nlo_set_radiation_event
procedure :: set_subtraction_event => pcm_instance_nlo_set_subtraction_event
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_set_radiation_event (pcm_instance)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
pcm_instance%real_sub%radiation_event = .true.
pcm_instance%real_sub%subtraction_event = .false.
end subroutine pcm_instance_nlo_set_radiation_event
subroutine pcm_instance_nlo_set_subtraction_event (pcm_instance)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
pcm_instance%real_sub%radiation_event = .false.
pcm_instance%real_sub%subtraction_event = .true.
end subroutine pcm_instance_nlo_set_subtraction_event
@ %def pcm_instance_nlo_set_radiation_event
@ %def pcm_instance_nlo_set_subtraction_event
<<Pcm: pcm instance: TBP>>=
procedure :: disable_subtraction => pcm_instance_nlo_disable_subtraction
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_disable_subtraction (pcm_instance)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
pcm_instance%real_sub%subtraction_deactivated = .true.
end subroutine pcm_instance_nlo_disable_subtraction
@ %def pcm_instance_nlo_disable_subtraction
@
<<Pcm: pcm instance: TBP>>=
procedure :: init_config => pcm_instance_nlo_init_config
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_init_config (pcm_instance, active_components, &
nlo_types, sqrts, i_real_fin, model)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
logical, intent(in), dimension(:) :: active_components
integer, intent(in), dimension(:) :: nlo_types
real(default), intent(in) :: sqrts
integer, intent(in) :: i_real_fin
class(model_data_t), intent(in) :: model
integer :: i_component
if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "pcm_instance_nlo_init_config")
call pcm_instance%init_real_and_isr_kinematics (sqrts)
select type (pcm => pcm_instance%config)
type is (pcm_nlo_t)
do i_component = 1, size (active_components)
if (active_components(i_component) .or. pcm%settings%combined_integration) then
select case (nlo_types(i_component))
case (NLO_REAL)
if (i_component /= i_real_fin) then
call pcm_instance%setup_real_component &
(pcm%settings%fks_template%subtraction_disabled)
end if
case (NLO_VIRTUAL)
call pcm_instance%init_virtual (model)
case (NLO_MISMATCH)
call pcm_instance%init_soft_mismatch ()
case (NLO_DGLAP)
call pcm_instance%init_dglap_remnant ()
end select
end if
end do
end select
end subroutine pcm_instance_nlo_init_config
@ %def pcm_instance_nlo_init_config
@
<<Pcm: pcm instance: TBP>>=
procedure :: setup_real_component => pcm_instance_nlo_setup_real_component
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_setup_real_component (pcm_instance, &
subtraction_disabled)
class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
logical, intent(in) :: subtraction_disabled
call pcm_instance%init_real_subtraction ()
if (subtraction_disabled) call pcm_instance%disable_subtraction ()
end subroutine pcm_instance_nlo_setup_real_component
@ %def pcm_instance_nlo_setup_real_component
@
<<Pcm: pcm instance: TBP>>=
procedure :: init_real_and_isr_kinematics => &
pcm_instance_nlo_init_real_and_isr_kinematics
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_init_real_and_isr_kinematics (pcm_instance, sqrts)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
real(default) :: sqrts
integer :: n_contr
allocate (pcm_instance%real_kinematics)
allocate (pcm_instance%isr_kinematics)
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
associate (region_data => config%region_data)
if (allocated (region_data%alr_contributors)) then
n_contr = size (region_data%alr_contributors)
else if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
n_contr = 2
else
n_contr = 1
end if
call pcm_instance%real_kinematics%init &
(region_data%n_legs_real, region_data%n_phs, &
region_data%n_regions, n_contr)
if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) &
call pcm_instance%real_kinematics%init_onshell &
(region_data%n_legs_real, region_data%n_phs)
pcm_instance%isr_kinematics%n_in = region_data%n_in
end associate
end select
pcm_instance%isr_kinematics%beam_energy = sqrts / two
end subroutine pcm_instance_nlo_init_real_and_isr_kinematics
@ %def pcm_instance_nlo_init_real_and_isr_kinematics
@
<<Pcm: pcm instance: TBP>>=
procedure :: set_real_and_isr_kinematics => &
pcm_instance_nlo_set_real_and_isr_kinematics
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_set_real_and_isr_kinematics (pcm_instance, phs_identifiers, sqrts)
class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
real(default), intent(in) :: sqrts
call pcm_instance%real_sub%set_real_kinematics &
(pcm_instance%real_kinematics)
call pcm_instance%real_sub%set_isr_kinematics &
(pcm_instance%isr_kinematics)
end subroutine pcm_instance_nlo_set_real_and_isr_kinematics
@ %def pcm_instance_nlo_set_real_and_isr_kinematics
@
<<Pcm: pcm instance: TBP>>=
procedure :: init_real_subtraction => pcm_instance_nlo_init_real_subtraction
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_init_real_subtraction (pcm_instance)
class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
associate (region_data => config%region_data)
call pcm_instance%real_sub%init (region_data, config%settings)
if (allocated (config%settings%selected_alr)) then
associate (selected_alr => config%settings%selected_alr)
if (any (selected_alr < 0)) then
call msg_fatal ("Fixed alpha region must be non-negative!")
else if (any (selected_alr > region_data%n_regions)) then
call msg_fatal ("Fixed alpha region is larger than the total"&
&" number of singular regions!")
else
allocate (pcm_instance%real_sub%selected_alr (size (selected_alr)))
pcm_instance%real_sub%selected_alr = selected_alr
end if
end associate
end if
end associate
end select
end subroutine pcm_instance_nlo_init_real_subtraction
@ %def pcm_instance_nlo_init_real_subtraction
@
<<Pcm: pcm instance: TBP>>=
procedure :: set_momenta_and_scales_virtual => &
pcm_instance_nlo_set_momenta_and_scales_virtual
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_set_momenta_and_scales_virtual (pcm_instance, p, &
ren_scale, fac_scale)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: ren_scale, fac_scale
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
associate (virtual => pcm_instance%virtual)
call virtual%set_ren_scale (p, ren_scale)
call virtual%set_fac_scale (p, fac_scale)
call virtual%set_ellis_sexton_scale ()
end associate
end select
end subroutine pcm_instance_nlo_set_momenta_and_scales_virtual
@ %def pcm_instance_nlo_set_momenta_and_scales_virtual
@
<<Pcm: pcm instance: TBP>>=
procedure :: set_fac_scale => pcm_instance_nlo_set_fac_scale
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_set_fac_scale (pcm_instance, fac_scale)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
real(default), intent(in) :: fac_scale
pcm_instance%isr_kinematics%fac_scale = fac_scale
end subroutine pcm_instance_nlo_set_fac_scale
@ %def pcm_instance_nlo_set_fac_scale
@
<<Pcm: pcm instance: TBP>>=
procedure :: set_momenta => pcm_instance_nlo_set_momenta
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_set_momenta (pcm_instance, p_born, p_real, i_phs, cms)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
type(vector4_t), dimension(:), intent(in) :: p_born, p_real
integer, intent(in) :: i_phs
logical, intent(in), optional :: cms
logical :: yorn
yorn = .false.; if (present (cms)) yorn = cms
associate (kinematics => pcm_instance%real_kinematics)
if (yorn) then
if (.not. kinematics%p_born_cms%initialized) &
call kinematics%p_born_cms%init (size (p_born), 1)
if (.not. kinematics%p_real_cms%initialized) &
call kinematics%p_real_cms%init (size (p_real), 1)
kinematics%p_born_cms%phs_point(1)%p = p_born
kinematics%p_real_cms%phs_point(i_phs)%p = p_real
else
if (.not. kinematics%p_born_lab%initialized) &
call kinematics%p_born_lab%init (size (p_born), 1)
if (.not. kinematics%p_real_lab%initialized) &
call kinematics%p_real_lab%init (size (p_real), 1)
kinematics%p_born_lab%phs_point(1)%p = p_born
kinematics%p_real_lab%phs_point(i_phs)%p = p_real
end if
end associate
end subroutine pcm_instance_nlo_set_momenta
@ %def pcm_instance_nlo_set_momenta
@
<<Pcm: pcm instance: TBP>>=
procedure :: get_momenta => pcm_instance_nlo_get_momenta
<<Pcm: procedures>>=
function pcm_instance_nlo_get_momenta (pcm_instance, i_phs, born_phsp, cms) result (p)
type(vector4_t), dimension(:), allocatable :: p
class(pcm_instance_nlo_t), intent(in) :: pcm_instance
integer, intent(in) :: i_phs
logical, intent(in) :: born_phsp
logical, intent(in), optional :: cms
logical :: yorn
yorn = .false.; if (present (cms)) yorn = cms
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
if (born_phsp) then
if (yorn) then
allocate (p (1 : config%region_data%n_legs_born), &
source = pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p)
else
allocate (p (1 : config%region_data%n_legs_born), &
source = pcm_instance%real_kinematics%p_born_lab%phs_point(1)%p)
end if
else
if (yorn) then
allocate (p (1 : config%region_data%n_legs_real), &
source = pcm_instance%real_kinematics%p_real_cms%phs_point(i_phs)%p)
else
allocate (p ( 1 : config%region_data%n_legs_real), &
source = pcm_instance%real_kinematics%p_real_lab%phs_point(i_phs)%p)
end if
end if
end select
end function pcm_instance_nlo_get_momenta
@ %def pcm_instance_nlo_get_momenta
@
<<Pcm: pcm instance: TBP>>=
procedure :: get_xi_max => pcm_instance_nlo_get_xi_max
<<Pcm: procedures>>=
function pcm_instance_nlo_get_xi_max (pcm_instance, alr) result (xi_max)
real(default) :: xi_max
class(pcm_instance_nlo_t), intent(in) :: pcm_instance
integer, intent(in) :: alr
integer :: i_phs
i_phs = pcm_instance%real_kinematics%alr_to_i_phs (alr)
xi_max = pcm_instance%real_kinematics%xi_max (i_phs)
end function pcm_instance_nlo_get_xi_max
@ %def pcm_instance_nlo_get_xi_max
@
<<Pcm: pcm instance: TBP>>=
procedure :: get_n_born => pcm_instance_nlo_get_n_born
<<Pcm: procedures>>=
function pcm_instance_nlo_get_n_born (pcm_instance) result (n_born)
integer :: n_born
class(pcm_instance_nlo_t), intent(in) :: pcm_instance
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
n_born = config%region_data%n_legs_born
end select
end function pcm_instance_nlo_get_n_born
@ %def pcm_instance_nlo_get_n_born
@
<<Pcm: pcm instance: TBP>>=
procedure :: get_n_real => pcm_instance_nlo_get_n_real
<<Pcm: procedures>>=
function pcm_instance_nlo_get_n_real (pcm_instance) result (n_real)
integer :: n_real
class(pcm_instance_nlo_t), intent(in) :: pcm_instance
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
n_real = config%region_data%n_legs_real
end select
end function pcm_instance_nlo_get_n_real
@ %def pcm_instance_nlo_get_n_real
@
<<Pcm: pcm instance: TBP>>=
procedure :: get_n_regions => pcm_instance_nlo_get_n_regions
<<Pcm: procedures>>=
function pcm_instance_nlo_get_n_regions (pcm_instance) result (n_regions)
integer :: n_regions
class(pcm_instance_nlo_t), intent(in) :: pcm_instance
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
n_regions = config%region_data%n_regions
end select
end function pcm_instance_nlo_get_n_regions
@ %def pcm_instance_nlo_get_n_regions
@
<<Pcm: pcm instance: TBP>>=
procedure :: set_x_rad => pcm_instance_nlo_set_x_rad
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_set_x_rad (pcm_instance, x_tot)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
real(default), intent(in), dimension(:) :: x_tot
integer :: n_par
n_par = size (x_tot)
if (n_par < 3) then
pcm_instance%real_kinematics%x_rad = zero
else
pcm_instance%real_kinematics%x_rad = x_tot (n_par - 2 : n_par)
end if
end subroutine pcm_instance_nlo_set_x_rad
@ %def pcm_instance_nlo_set_x_rad
@
<<Pcm: pcm instance: TBP>>=
procedure :: init_virtual => pcm_instance_nlo_init_virtual
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_init_virtual (pcm_instance, model)
class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
class(model_data_t), intent(in) :: model
type(nlo_settings_t), pointer :: settings
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
associate (region_data => config%region_data)
settings => config%settings
call pcm_instance%virtual%init (region_data%get_flv_states_born (), &
region_data%n_in, settings, &
region_data%regions(1)%nlo_correction_type, model, config%has_pdfs)
end associate
end select
end subroutine pcm_instance_nlo_init_virtual
@ %def pcm_instance_nlo_init_virtual
@
<<Pcm: pcm instance: TBP>>=
procedure :: disable_virtual_subtraction => pcm_instance_nlo_disable_virtual_subtraction
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_disable_virtual_subtraction (pcm_instance)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
end subroutine pcm_instance_nlo_disable_virtual_subtraction
@ %def pcm_instance_nlo_disable_virtual_subtraction
@
<<Pcm: pcm instance: TBP>>=
procedure :: compute_sqme_virt => pcm_instance_nlo_compute_sqme_virt
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_compute_sqme_virt (pcm_instance, p, &
alpha_coupling, separate_alrs, sqme_virt)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: alpha_coupling
logical, intent(in) :: separate_alrs
real(default), dimension(:), allocatable, intent(inout) :: sqme_virt
type(vector4_t), dimension(:), allocatable :: pp
associate (virtual => pcm_instance%virtual)
allocate (pp (size (p)))
if (virtual%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
pp = pcm_instance%real_kinematics%p_born_onshell%get_momenta (1)
else
pp = p
end if
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
if (separate_alrs) then
allocate (sqme_virt (config%get_n_flv_born ()))
else
allocate (sqme_virt (1))
end if
sqme_virt = zero
call virtual%evaluate (config%region_data, &
alpha_coupling, pp, separate_alrs, sqme_virt)
end select
end associate
end subroutine pcm_instance_nlo_compute_sqme_virt
@ %def pcm_instance_nlo_compute_sqme_virt
@
<<Pcm: pcm instance: TBP>>=
procedure :: compute_sqme_mismatch => pcm_instance_nlo_compute_sqme_mismatch
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_compute_sqme_mismatch (pcm_instance, &
alpha_s, separate_alrs, sqme_mism)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
real(default), intent(in) :: alpha_s
logical, intent(in) :: separate_alrs
real(default), dimension(:), allocatable, intent(inout) :: sqme_mism
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
if (separate_alrs) then
allocate (sqme_mism (config%get_n_flv_born ()))
else
allocate (sqme_mism (1))
end if
sqme_mism = zero
sqme_mism = pcm_instance%soft_mismatch%evaluate (alpha_s)
end select
end subroutine pcm_instance_nlo_compute_sqme_mismatch
@ %def pcm_instance_nlo_compute_sqme_mismatch
@
<<Pcm: pcm instance: TBP>>=
procedure :: compute_sqme_dglap_remnant => pcm_instance_nlo_compute_sqme_dglap_remnant
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_compute_sqme_dglap_remnant (pcm_instance, &
alpha_s, separate_alrs, sqme_dglap)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
real(default), intent(in) :: alpha_s
logical, intent(in) :: separate_alrs
real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
if (separate_alrs) then
allocate (sqme_dglap (config%get_n_flv_born ()))
else
allocate (sqme_dglap (1))
end if
end select
sqme_dglap = zero
call pcm_instance%dglap_remnant%evaluate (alpha_s, separate_alrs, sqme_dglap)
end subroutine pcm_instance_nlo_compute_sqme_dglap_remnant
@ %def pcm_instance_nlo_compute_sqme_dglap_remnant
@
<<Pcm: pcm instance: TBP>>=
procedure :: set_fixed_order_event_mode => pcm_instance_nlo_set_fixed_order_event_mode
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_set_fixed_order_event_mode (pcm_instance)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
pcm_instance%real_sub%purpose = FIXED_ORDER_EVENTS
end subroutine pcm_instance_nlo_set_fixed_order_event_mode
<<Pcm: pcm instance: TBP>>=
procedure :: set_powheg_mode => pcm_instance_nlo_set_powheg_mode
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_set_powheg_mode (pcm_instance)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
pcm_instance%real_sub%purpose = POWHEG
end subroutine pcm_instance_nlo_set_powheg_mode
@ %def pcm_instance_nlo_set_fixed_order_event_mode
@ %def pcm_instance_nlo_set_powheg_mode
@
<<Pcm: pcm instance: TBP>>=
procedure :: init_soft_mismatch => pcm_instance_nlo_init_soft_mismatch
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_init_soft_mismatch (pcm_instance)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
call pcm_instance%soft_mismatch%init (config%region_data, &
pcm_instance%real_kinematics, config%settings%factorization_mode)
end select
end subroutine pcm_instance_nlo_init_soft_mismatch
@ %def pcm_instance_nlo_init_soft_mismatch
@
<<Pcm: pcm instance: TBP>>=
procedure :: init_dglap_remnant => pcm_instance_nlo_init_dglap_remnant
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_init_dglap_remnant (pcm_instance)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
call pcm_instance%dglap_remnant%init ( &
config%settings, &
config%region_data%n_flv_born, &
pcm_instance%isr_kinematics, &
config%region_data%get_flv_states_born (), config%get_n_alr ())
end select
end subroutine pcm_instance_nlo_init_dglap_remnant
@ %def pcm_instance_nlo_init_dglap_remnant
@
<<Pcm: pcm instance: TBP>>=
procedure :: is_fixed_order_nlo_events &
=> pcm_instance_nlo_is_fixed_order_nlo_events
<<Pcm: procedures>>=
function pcm_instance_nlo_is_fixed_order_nlo_events (pcm_instance) result (is_nlo)
logical :: is_nlo
class(pcm_instance_nlo_t), intent(in) :: pcm_instance
is_nlo = pcm_instance%real_sub%purpose == FIXED_ORDER_EVENTS
end function pcm_instance_nlo_is_fixed_order_nlo_events
@ %def pcm_instance_nlo_is_fixed_order_nlo_events
@
<<Pcm: pcm instance: TBP>>=
procedure :: final => pcm_instance_nlo_final
<<Pcm: procedures>>=
subroutine pcm_instance_nlo_final (pcm_instance)
class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
call pcm_instance%real_sub%final ()
call pcm_instance%virtual%final ()
call pcm_instance%soft_mismatch%final ()
call pcm_instance%dglap_remnant%final ()
if (associated (pcm_instance%real_kinematics)) then
call pcm_instance%real_kinematics%final ()
nullify (pcm_instance%real_kinematics)
end if
if (associated (pcm_instance%isr_kinematics)) then
nullify (pcm_instance%isr_kinematics)
end if
end subroutine pcm_instance_nlo_final
@ %def pcm_instance_nlo_final
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Kinematics instance}
In this data type we combine all objects (instances) necessary for
generating (or recovering) a kinematical configuration. The
components work together as an implementation of multi-channel phase
space.
[[sf_chain]] is an instance of the structure-function chain. It is
used both for generating kinematics and, after the proper scale has
been determined, evaluating the structure function entries.
[[phs]] is an instance of the phase space for the elementary process.
The array [[f]] contains the products of the Jacobians that originate
from parameter mappings in the structure-function chain or in the
phase space. We allocate this explicitly if either [[sf_chain]] or
[[phs]] are explicitly allocated, otherwise we can take over a pointer.
All components are implemented as pointers to (anonymous) targets.
For each component, there is a flag that tells whether this component
is to be regarded as a proper component (`owned' by the object) or as
a pointer.
@
<<[[kinematics.f90]]>>=
<<File header>>
module kinematics
<<Use kinds>>
use format_utils, only: write_separator
use diagnostics
use io_units
use lorentz
use physics_defs
use sf_base
use phs_base
use interactions
use mci_base
use phs_fks
use fks_regions
use process_config
use process_mci
use pcm, only: pcm_instance_nlo_t
use ttv_formfactors, only: m1s_to_mpole
<<Standard module head>>
<<Kinematics: public>>
<<Kinematics: types>>
contains
<<Kinematics: procedures>>
end module kinematics
@ %def kinematics
<<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: procedures>>=
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: procedures>>=
subroutine kinematics_final (object)
class(kinematics_t), intent(inout) :: object
if (object%sf_chain_allocated) then
call object%sf_chain%final ()
deallocate (object%sf_chain)
object%sf_chain_allocated = .false.
end if
if (object%phs_allocated) then
call object%phs%final ()
deallocate (object%phs)
object%phs_allocated = .false.
end if
if (object%f_allocated) then
deallocate (object%f)
object%f_allocated = .false.
end if
end subroutine kinematics_final
@ %def kinematics_final
@ Set the flags indicating whether the phase space shall be set up for the calculation of the real contribution. For this case, also set the emitter.
<<Kinematics: kinematics: TBP>>=
procedure :: set_nlo_info => kinematics_set_nlo_info
<<Kinematics: procedures>>=
subroutine kinematics_set_nlo_info (k, nlo_type)
class(kinematics_t), intent(inout) :: k
integer, intent(in) :: nlo_type
if (nlo_type == NLO_VIRTUAL) k%only_cm_frame = .true.
end subroutine kinematics_set_nlo_info
@ %def kinematics_set_nlo_info
@ Allocate the structure-function chain instance, initialize it as a
copy of the [[sf_chain]] template, and prepare it for evaluation.
The [[sf_chain]] remains a target because the (usually constant) beam momenta
are taken from there.
<<Kinematics: kinematics: TBP>>=
procedure :: init_sf_chain => kinematics_init_sf_chain
<<Kinematics: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine kinematics_evaluate_radiation_kinematics (k, r_in)
class(kinematics_t), intent(inout) :: k
real(default), intent(in), dimension(:) :: r_in
select type (phs => k%phs)
type is (phs_fks_t)
call phs%generate_radiation_variables &
(r_in(phs%n_r_born + 1 : phs%n_r_born + 3), k%threshold)
call phs%compute_cms_energy ()
end select
end subroutine kinematics_evaluate_radiation_kinematics
@ %def kinematics_evaluate_radiation_kinematics
@
<<Kinematics: kinematics: TBP>>=
procedure :: compute_xi_ref_momenta => kinematics_compute_xi_ref_momenta
<<Kinematics: procedures>>=
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: procedures>>=
subroutine kinematics_compute_selected_channel &
(k, mci_work, phs_channel, p, success)
class(kinematics_t), intent(inout) :: k
type(mci_work_t), intent(in) :: mci_work
integer, intent(in) :: phs_channel
type(vector4_t), dimension(:), intent(out) :: p
logical, intent(out) :: success
integer :: sf_channel
k%selected_channel = phs_channel
sf_channel = k%phs%config%get_sf_channel (phs_channel)
call k%sf_chain%compute_kinematics (sf_channel, mci_work%get_x_strfun ())
call k%sf_chain%get_out_momenta (p(1:k%n_in))
call k%phs%set_incoming_momenta (p(1:k%n_in))
call k%phs%compute_flux ()
call k%phs%select_channel (phs_channel)
call k%phs%evaluate_selected_channel (phs_channel, &
mci_work%get_x_process ())
select type (phs => k%phs)
type is (phs_fks_t)
if (phs%q_defined) then
call phs%get_born_momenta (p)
k%phs_factor = phs%get_overall_factor ()
success = .true.
else
k%phs_factor = 0
success = .false.
end if
class default
if (phs%q_defined) then
call k%phs%get_outgoing_momenta (p(k%n_in + 1 :))
k%phs_factor = k%phs%get_overall_factor ()
success = .true.
if (k%only_cm_frame) then
if (.not. k%lab_is_cm_frame()) &
call k%boost_to_cm_frame (p)
end if
else
k%phs_factor = 0
success = .false.
end if
end select
end subroutine kinematics_compute_selected_channel
@ %def kinematics_compute_selected_channel
@ Complete kinematics by filling the non-selected phase-space parameter
arrays.
<<Kinematics: kinematics: TBP>>=
procedure :: compute_other_channels => kinematics_compute_other_channels
<<Kinematics: procedures>>=
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: procedures>>=
subroutine kinematics_get_incoming_momenta (k, p)
class(kinematics_t), intent(in) :: k
type(vector4_t), dimension(:), intent(out) :: p
type(interaction_t), pointer :: int
integer :: i
int => k%sf_chain%get_out_int_ptr ()
do i = 1, k%n_in
p(i) = int%get_momentum (k%sf_chain%get_out_i (i))
end do
end subroutine kinematics_get_incoming_momenta
@ %def kinematics_get_incoming_momenta
@ This inverts the remainder of the above [[compute]] method. We know
the momenta and recover the rest, as far as needed. If we select a
channel, we can complete the inversion and reconstruct the
MC parameter set.
<<Kinematics: kinematics: TBP>>=
procedure :: recover_mcpar => kinematics_recover_mcpar
<<Kinematics: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine kinematics_evaluate_sf_chain (k, fac_scale, sf_rescale)
class(kinematics_t), intent(inout) :: k
real(default), intent(in) :: fac_scale
class(sf_rescale_t), intent(inout), optional :: sf_rescale
select case (k%sf_chain%get_status ())
case (SF_DONE_KINEMATICS)
call k%sf_chain%evaluate (fac_scale, sf_rescale)
end select
end subroutine kinematics_evaluate_sf_chain
@ %def kinematics_evaluate_sf_chain
@ Recover beam momenta, i.e., return the beam momenta stored in the
current [[sf_chain]] to their source. This is a side effect.
<<Kinematics: kinematics: TBP>>=
procedure :: return_beam_momenta => kinematics_return_beam_momenta
<<Kinematics: procedures>>=
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_frame => kinematics_lab_is_cm_frame
<<Kinematics: procedures>>=
function kinematics_lab_is_cm_frame (k) result (cm_frame)
logical :: cm_frame
class(kinematics_t), intent(in) :: k
cm_frame = k%phs%config%cm_frame
end function kinematics_lab_is_cm_frame
@ %def kinematics_lab_is_cm_frame
@ Boost to center-of-mass frame
<<Kinematics: kinematics: TBP>>=
procedure :: boost_to_cm_frame => kinematics_boost_to_cm_frame
<<Kinematics: procedures>>=
subroutine kinematics_boost_to_cm_frame (k, p)
class(kinematics_t), intent(in) :: k
type(vector4_t), intent(inout), dimension(:) :: p
p = inverse (k%phs%lt_cm_to_lab) * p
end subroutine kinematics_boost_to_cm_frame
@ %def kinematics_boost_to_cm_frame
@
<<Kinematics: kinematics: TBP>>=
procedure :: modify_momenta_for_subtraction => kinematics_modify_momenta_for_subtraction
<<Kinematics: procedures>>=
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: procedures>>=
subroutine kinematics_threshold_projection (k, pcm_instance, nlo_type)
class(kinematics_t), intent(inout) :: k
type(pcm_instance_nlo_t), intent(inout) :: pcm_instance
integer, intent(in) :: nlo_type
real(default) :: sqrts, mtop
type(lorentz_transformation_t) :: L_to_cms
type(vector4_t), dimension(:), allocatable :: p_tot
integer :: n_tot
n_tot = k%phs%get_n_tot ()
allocate (p_tot (size (pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p)))
select type (phs => k%phs)
type is (phs_fks_t)
p_tot = pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p
class default
p_tot(1 : k%n_in) = phs%p
p_tot(k%n_in + 1 : n_tot) = phs%q
end select
sqrts = sum (p_tot (1:k%n_in))**1
mtop = m1s_to_mpole (sqrts)
L_to_cms = get_boost_for_threshold_projection (p_tot, sqrts, mtop)
call pcm_instance%real_kinematics%p_born_cms%set_momenta (1, p_tot)
associate (p_onshell => pcm_instance%real_kinematics%p_born_onshell%phs_point(1)%p)
call threshold_projection_born (mtop, L_to_cms, p_tot, p_onshell)
if (debug2_active (D_THRESHOLD)) then
print *, 'On-shell projected Born: '
call vector4_write_set (p_onshell)
end if
end associate
end subroutine kinematics_threshold_projection
@ %def kinematics_threshold_projection
@
<<Kinematics: kinematics: TBP>>=
procedure :: evaluate_radiation => kinematics_evaluate_radiation
<<Kinematics: procedures>>=
subroutine kinematics_evaluate_radiation (k, p_in, p_out, success)
class(kinematics_t), intent(inout) :: k
type(vector4_t), intent(in), dimension(:) :: p_in
type(vector4_t), intent(out), dimension(:), allocatable :: p_out
logical, intent(out) :: success
type(vector4_t), dimension(:), allocatable :: p_real
type(vector4_t), dimension(:), allocatable :: p_born
real(default) :: xi_max_offshell, xi_offshell, y_offshell, jac_rand_dummy, phi
select type (phs => k%phs)
type is (phs_fks_t)
allocate (p_born (size (p_in)))
if (k%threshold) then
p_born = phs%get_onshell_projected_momenta ()
else
p_born = p_in
end if
if (.not. k%phs%is_cm_frame () .and. .not. k%threshold) then
p_born = inverse (k%phs%lt_cm_to_lab) * p_born
end if
call phs%compute_xi_max (p_born, k%threshold)
if (k%emitter >= 0) then
allocate (p_real (size (p_born) + 1))
allocate (p_out (size (p_born) + 1))
if (k%emitter <= k%n_in) then
call phs%generate_isr (k%i_phs, p_real)
else
if (k%threshold) then
jac_rand_dummy = 1._default
call compute_y_from_emitter (phs%generator%real_kinematics%x_rad (I_Y), &
phs%generator%real_kinematics%p_born_cms%get_momenta(1), &
k%n_in, k%emitter, .false., phs%generator%y_max, jac_rand_dummy, &
y_offshell)
call phs%compute_xi_max (k%emitter, k%i_phs, y_offshell, &
phs%generator%real_kinematics%p_born_cms%get_momenta(1), &
xi_max_offshell)
xi_offshell = xi_max_offshell * phs%generator%real_kinematics%xi_tilde
phi = phs%generator%real_kinematics%phi
call phs%generate_fsr (k%emitter, k%i_phs, p_real, &
xi_y_phi = [xi_offshell, y_offshell, phi], no_jacobians = .true.)
call phs%generator%real_kinematics%p_real_cms%set_momenta (k%i_phs, p_real)
call phs%generate_fsr_threshold (k%emitter, k%i_phs, p_real)
if (debug2_active (D_SUBTRACTION)) &
call generate_fsr_threshold_for_other_emitters (k%emitter, k%i_phs)
else if (k%i_con > 0) then
call phs%generate_fsr (k%emitter, k%i_phs, p_real, k%i_con)
else
call phs%generate_fsr (k%emitter, k%i_phs, p_real)
end if
end if
success = check_scalar_products (p_real)
if (debug2_active (D_SUBTRACTION)) then
call msg_debug2 (D_SUBTRACTION, "Real phase-space: ")
call vector4_write_set (p_real)
end if
p_out = p_real
else
allocate (p_out (size (p_in))); p_out = p_in
success = .true.
end if
end select
contains
subroutine generate_fsr_threshold_for_other_emitters (emitter, i_phs)
integer, intent(in) :: emitter, i_phs
integer :: ii_phs, this_emitter
select type (phs => k%phs)
type is (phs_fks_t)
do ii_phs = 1, size (phs%phs_identifiers)
this_emitter = phs%phs_identifiers(ii_phs)%emitter
if (ii_phs /= i_phs .and. this_emitter /= emitter) &
call phs%generate_fsr_threshold (this_emitter, i_phs)
end do
end select
end subroutine
end subroutine kinematics_evaluate_radiation
@ %def kinematics_evaluate_radiation
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Instances}
<<[[instances.f90]]>>=
<<File header>>
module instances
<<Use kinds>>
<<Use strings>>
<<Use debug>>
use io_units
use format_utils, only: write_separator
use constants
use diagnostics
use os_interface
use numeric_utils
use lorentz
use mci_base
use particles
use sm_qcd, only: qcd_t
use interactions
use quantum_numbers
use model_data
use helicities
use flavors
use beam_structures
use variables
use pdg_arrays, only: is_quark
use sf_base
use isr_collinear
use physics_defs
use process_constants
use process_libraries
use state_matrices
use integration_results
use phs_base
use prc_core, only: prc_core_t, prc_core_state_t
!!! We should depend less on these modules (move it to pcm_nlo_t e.g.)
use phs_wood, only: phs_wood_t
use phs_fks
use blha_olp_interfaces, only: prc_blha_t
use blha_config, only: BLHA_AMP_COLOR_C
use prc_external, only: prc_external_t, prc_external_state_t
use prc_threshold, only: prc_threshold_t
use blha_olp_interfaces, only: blha_result_array_size
use prc_openloops, only: prc_openloops_t, openloops_state_t
use prc_recola, only: prc_recola_t
use blha_olp_interfaces, only: blha_color_c_fill_offdiag, blha_color_c_fill_diag
use ttv_formfactors, only: m1s_to_mpole
!!! local modules
use parton_states
use process_counter
use pcm_base
use pcm
use process_config
use process_mci
use process
use kinematics
<<Standard module head>>
<<Instances: public>>
<<Instances: types>>
<<Instances: interfaces>>
contains
<<Instances: procedures>>
end module instances
@ %def instances
@
\subsection{Term instance}
A [[term_instance_t]] object contains all data that describe a term. Each
process component consists of one or more distinct terms which may differ in
kinematics, but whose squared transition matrices have to be added pointwise.
The [[active]] flag is set when this term is connected to an active
process component. Inactive terms are skipped for kinematics and evaluation.
The [[k_term]] object is the instance of the kinematics setup
(structure-function chain, phase space, etc.) that applies
specifically to this term. In ordinary cases, it consists of straight
pointers to the seed kinematics.
The [[amp]] array stores the amplitude values when we get them from evaluating
the associated matrix-element code.
The [[int_hard]] interaction describes the elementary hard process.
It receives the momenta and the amplitude entries for each sampling point.
The [[isolated]] object holds the effective parton state for the
elementary interaction. The amplitude entries are
computed from [[int_hard]].
The [[connected]] evaluator set
convolutes this scattering matrix with the beam (and possibly
structure-function) density matrix.
The [[checked]] flag is set once we have applied cuts on this term.
The result of this is stored in the [[passed]] flag. Once the term
has passed cuts, we calculate the various scale and weight expressions.
<<Instances: types>>=
type :: term_instance_t
type(process_term_t), pointer :: config => null ()
logical :: active = .false.
type(kinematics_t) :: k_term
complex(default), dimension(:), allocatable :: amp
type(interaction_t) :: int_hard
type(isolated_state_t) :: isolated
type(connected_state_t) :: connected
class(prc_core_state_t), allocatable :: core_state
logical :: checked = .false.
logical :: passed = .false.
real(default) :: scale = 0
real(default) :: fac_scale = 0
real(default) :: ren_scale = 0
real(default), allocatable :: alpha_qcd_forced
real(default) :: weight = 1
type(vector4_t), dimension(:), allocatable :: p_seed
type(vector4_t), dimension(:), allocatable :: p_hard
class(pcm_instance_t), pointer :: pcm_instance => null ()
integer :: nlo_type = BORN
integer, dimension(:), allocatable :: same_kinematics
type(qn_index_map_t) :: connected_qn_index
type(qn_index_map_t) :: hard_qn_index
contains
<<Instances: term instance: TBP>>
end type term_instance_t
@ %def term_instance_t
@
<<Instances: term instance: TBP>>=
procedure :: write => term_instance_write
<<Instances: procedures>>=
subroutine term_instance_write (term, unit, show_eff_state, testflag)
class(term_instance_t), intent(in) :: term
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_eff_state
logical, intent(in), optional :: testflag
integer :: u
logical :: state
u = given_output_unit (unit)
state = .true.; if (present (show_eff_state)) state = show_eff_state
if (term%active) then
if (associated (term%config)) then
write (u, "(1x,A,I0,A,I0,A)") "Term #", term%config%i_term, &
" (component #", term%config%i_component, ")"
else
write (u, "(1x,A)") "Term [undefined]"
end if
else
write (u, "(1x,A,I0,A)") "Term #", term%config%i_term, &
" [inactive]"
end if
if (term%checked) then
write (u, "(3x,A,L1)") "passed cuts = ", term%passed
end if
if (term%passed) then
write (u, "(3x,A,ES19.12)") "overall scale = ", term%scale
write (u, "(3x,A,ES19.12)") "factorization scale = ", term%fac_scale
write (u, "(3x,A,ES19.12)") "renormalization scale = ", term%ren_scale
if (allocated (term%alpha_qcd_forced)) then
write (u, "(3x,A,ES19.12)") "alpha(QCD) forced = ", &
term%alpha_qcd_forced
end if
write (u, "(3x,A,ES19.12)") "reweighting factor = ", term%weight
end if
call term%k_term%write (u)
call write_separator (u)
write (u, "(1x,A)") "Amplitude (transition matrix of the &
&hard interaction):"
call write_separator (u)
call term%int_hard%basic_write (u, testflag = testflag)
if (state .and. term%isolated%has_trace) then
call write_separator (u)
write (u, "(1x,A)") "Evaluators for the hard interaction:"
call term%isolated%write (u, testflag = testflag)
end if
if (state .and. term%connected%has_trace) then
call write_separator (u)
write (u, "(1x,A)") "Evaluators for the connected process:"
call term%connected%write (u, testflag = testflag)
end if
end subroutine term_instance_write
@ %def term_instance_write
@ The interactions and evaluators must be finalized.
<<Instances: term instance: TBP>>=
procedure :: final => term_instance_final
<<Instances: procedures>>=
subroutine term_instance_final (term)
class(term_instance_t), intent(inout) :: term
if (allocated (term%amp)) deallocate (term%amp)
if (allocated (term%core_state)) deallocate (term%core_state)
if (allocated (term%alpha_qcd_forced)) &
deallocate (term%alpha_qcd_forced)
if (allocated (term%p_seed)) deallocate(term%p_seed)
if (allocated (term%p_hard)) deallocate (term%p_hard)
call term%k_term%final ()
call term%connected%final ()
call term%isolated%final ()
call term%int_hard%final ()
term%pcm_instance => null ()
end subroutine term_instance_final
@ %def term_instance_final
@ For initialization, we make use of defined assignment for the
[[interaction_t]] type. This creates a deep copy.
The hard interaction (incoming momenta) is linked to the structure
function instance. In the isolated state, we either set pointers to
both, or we create modified copies ([[rearrange]]) as effective
structure-function chain and interaction, respectively.
Finally, we set up the [[subevt]] component that will be used for
evaluating observables, collecting particles from the trace evaluator
in the effective connected state. Their quantum numbers must be
determined by following back source links and set explicitly, since
they are already eliminated in that trace.
The [[rearrange]] parts are still commented out; they could become
relevant for a NLO algorithm.
<<Instances: term instance: TBP>>=
procedure :: init => term_instance_init
<<Instances: procedures>>=
subroutine term_instance_init (term, process, i_term, real_finite)
class(term_instance_t), intent(inout), target :: term
type(process_t), intent(in), target:: process
integer, intent(in) :: i_term
logical, intent(in), optional :: real_finite
class(prc_core_t), pointer :: core => null ()
type(process_beam_config_t) :: beam_config
type(interaction_t), pointer :: sf_chain_int
type(interaction_t), pointer :: src_int
type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
type(state_matrix_t), pointer :: state_matrix
type(flavor_t), dimension(:), allocatable :: flv_int, flv_src, f_in, f_out
integer :: n_in, n_vir, n_out, n_tot, n_sub
integer :: i, j
logical :: me_already_squared, keep_fs_flavors
logical :: decrease_n_tot
logical :: requires_extended_sf
me_already_squared = .false.
keep_fs_flavors = .false.
term%config => process%get_term_ptr (i_term)
term%int_hard = term%config%int
core => process%get_core_term (i_term)
call core%allocate_workspace (term%core_state)
select type (core)
class is (prc_external_t)
call reduce_interaction (term%int_hard, &
core%includes_polarization (), .true., .false.)
me_already_squared = .true.
allocate (term%amp (term%int_hard%get_n_matrix_elements ()))
class default
allocate (term%amp (term%config%n_allowed))
end select
if (allocated (term%core_state)) then
select type (core_state => term%core_state)
type is (openloops_state_t)
call core_state%init_threshold (process%get_model_ptr ())
end select
end if
term%amp = cmplx (0, 0, default)
decrease_n_tot = term%nlo_type == NLO_REAL .and. &
term%config%i_term_global /= term%config%i_sub
if (present (real_finite)) then
if (real_finite) decrease_n_tot = .false.
end if
if (decrease_n_tot) then
allocate (term%p_seed (term%int_hard%get_n_tot () - 1))
else
allocate (term%p_seed (term%int_hard%get_n_tot ()))
end if
allocate (term%p_hard (term%int_hard%get_n_tot ()))
sf_chain_int => term%k_term%sf_chain%get_out_int_ptr ()
n_in = term%int_hard%get_n_in ()
do j = 1, n_in
i = term%k_term%sf_chain%get_out_i (j)
call term%int_hard%set_source_link (j, sf_chain_int, i)
end do
call term%isolated%init (term%k_term%sf_chain, term%int_hard)
allocate (mask_in (n_in))
mask_in = term%k_term%sf_chain%get_out_mask ()
select type (phs => term%k_term%phs)
type is (phs_wood_t)
if (me_already_squared) then
call term%isolated%setup_identity_trace (core, mask_in, .true., .false.)
else
call term%isolated%setup_square_trace (core, mask_in, term%config%col, .false.)
end if
type is (phs_fks_t)
select case (phs%mode)
case (PHS_MODE_ADDITIONAL_PARTICLE)
if (me_already_squared) then
call term%isolated%setup_identity_trace (core, mask_in, .true., .false.)
else
keep_fs_flavors = term%config%data%n_flv > 1
call term%isolated%setup_square_trace (core, mask_in, term%config%col, &
keep_fs_flavors)
end if
case (PHS_MODE_COLLINEAR_REMNANT)
if (me_already_squared) then
call term%isolated%setup_identity_trace (core, mask_in, .true., .false.)
else
call term%isolated%setup_square_trace (core, mask_in, term%config%col, .false.)
end if
end select
class default
call term%isolated%setup_square_trace (core, mask_in, term%config%col, .false.)
end select
if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL .and. &
term%config%i_term_global == term%config%i_sub) .or. &
term%nlo_type == NLO_MISMATCH) then
n_sub = term%get_n_sub ()
else if (term%nlo_type == NLO_DGLAP) then
n_sub = n_beam_structure_int
else
!!! No integration of real subtraction in interactions yet
n_sub = 0
end if
keep_fs_flavors = keep_fs_flavors .or. me_already_squared
requires_extended_sf = term%nlo_type == NLO_DGLAP .or. &
(term%is_subtraction () .and. process%pcm_contains_pdfs ())
call term%connected%setup_connected_trace (term%isolated, &
undo_helicities = undo_helicities (core, me_already_squared), &
keep_fs_flavors = keep_fs_flavors, &
extended_sf = requires_extended_sf)
associate (int_eff => term%isolated%int_eff)
state_matrix => int_eff%get_state_matrix_ptr ()
n_tot = int_eff%get_n_tot ()
flv_int = quantum_numbers_get_flavor &
(state_matrix%get_quantum_number (1))
allocate (f_in (n_in))
f_in = flv_int(1:n_in)
deallocate (flv_int)
end associate
n_in = term%connected%trace%get_n_in ()
n_vir = term%connected%trace%get_n_vir ()
n_out = term%connected%trace%get_n_out ()
allocate (f_out (n_out))
do j = 1, n_out
call term%connected%trace%find_source &
(n_in + n_vir + j, src_int, i)
if (associated (src_int)) then
state_matrix => src_int%get_state_matrix_ptr ()
flv_src = quantum_numbers_get_flavor &
(state_matrix%get_quantum_number (1))
f_out(j) = flv_src(i)
deallocate (flv_src)
end if
end do
beam_config = process%get_beam_config ()
call term%connected%setup_subevt (term%isolated%sf_chain_eff, &
beam_config%data%flv, f_in, f_out)
call term%connected%setup_var_list &
(process%get_var_list_ptr (), beam_config%data)
select type (core)
class is (prc_external_t)
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
associate (is_born => .not. (term%nlo_type == NLO_REAL .and. .not. term%is_subtraction ()))
! Does connected%trace never have any helicity qn?
call setup_qn_index (term%connected_qn_index, term%connected%trace, pcm_instance, &
n_sub = n_sub, is_born = is_born, is_polarized = .false.)
call setup_qn_index (term%hard_qn_index, term%int_hard, pcm_instance, &
n_sub = n_sub, is_born = is_born, is_polarized = core%includes_polarization ())
end associate
class default
call term%connected_qn_index%init (term%connected%trace)
call term%hard_qn_index%init (term%int_hard)
end select
class default
call term%connected_qn_index%init (term%connected%trace)
call term%hard_qn_index%init (term%int_hard)
end select
contains
function undo_helicities (core, me_squared) result (val)
logical :: val
class(prc_core_t), intent(in) :: core
logical, intent(in) :: me_squared
select type (core)
class is (prc_external_t)
val = me_squared .and. .not. core%includes_polarization ()
class default
val = .false.
end select
end function undo_helicities
subroutine reduce_interaction (int, polarized_beams, keep_fs_flavors, &
keep_colors)
type(interaction_t), intent(inout) :: int
logical, intent(in) :: polarized_beams
logical, intent(in) :: keep_fs_flavors, keep_colors
type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
logical, dimension(:), allocatable :: mask_f, mask_c, mask_h
integer :: n_tot, n_in
n_in = int%get_n_in (); n_tot = int%get_n_tot ()
allocate (qn_mask (n_tot))
allocate (mask_f (n_tot), mask_c (n_tot), mask_h (n_tot))
mask_c = .not. keep_colors
mask_f (1 : n_in) = .false.
if (keep_fs_flavors) then
mask_f (n_in + 1 : ) = .false.
else
mask_f (n_in + 1 : ) = .true.
end if
if (polarized_beams) then
mask_h (1 : n_in) = .false.
else
mask_h (1 : n_in) = .true.
end if
mask_h (n_in + 1 : ) = .true.
call qn_mask%init (mask_f, mask_c, mask_h)
call int%reduce_state_matrix (qn_mask, keep_order = .true.)
end subroutine reduce_interaction
<<Instances: term instance init: procedures>>
end subroutine term_instance_init
@ %def term_instance_init
@ Setup index mapping from state matrix to index pair [[i_flv]], [[i_sub]].
<<Instances: term instance init: procedures>>=
subroutine setup_qn_index (qn_index, int, pcm_instance, n_sub, is_born, is_polarized)
type(qn_index_map_t), intent(out) :: qn_index
class(interaction_t), intent(in) :: int
class(pcm_instance_t), intent(in) :: pcm_instance
integer, intent(in) :: n_sub
logical, intent(in) :: is_born
logical, intent(in) :: is_polarized
integer :: i
type(quantum_numbers_t), dimension(:, :), allocatable :: qn_config
type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
qn_config = config%get_qn (is_born)
end select
if (is_polarized) then
! term%config%data from higher scope
call setup_qn_hel (int, term%config%data, qn_hel)
call qn_index%init (int, qn_config, n_sub, qn_hel)
call qn_index%set_helicity_flip (.true.)
else
call qn_index%init (int, qn_config, n_sub)
end if
end subroutine setup_qn_index
@ %def setup_qn_index
@ Setup beam polarisation quantum numbers, iff beam polarisation is required.
We retrieve the full helicity information from [[term%config%data]] and reduce
the information only to the inital state. Afterwards, we uniquify the initial
state polarization by a applying a index (hash) table.
The helicity information is fed into an array of quantum numbers to assign
flavor, helicity and subtraction indices correctly to their matrix element.
<<Instances: term instance init: procedures>>=
subroutine setup_qn_hel (int, data, qn_hel)
class(interaction_t), intent(in) :: int
class(process_constants_t), intent(in) :: data
type(quantum_numbers_t), dimension(:, :), allocatable, intent(out) :: qn_hel
type(helicity_t), dimension(:), allocatable :: hel
integer, dimension(:), allocatable :: index_table
integer, dimension(:, :), allocatable :: hel_state
integer :: i, j, n_hel_unique
associate (n_in => int%get_n_in (), n_tot => int%get_n_tot ())
allocate (hel_state (n_tot, data%get_n_hel ()), &
source = data%hel_state)
allocate (index_table (data%get_n_hel ()), &
source = 0)
forall (j=1:data%get_n_hel (), i=n_in+1:n_tot) hel_state(i, j) = 0
n_hel_unique = 0
HELICITY: do i = 1, data%get_n_hel ()
do j = 1, data%get_n_hel ()
if (index_table (j) == 0) then
index_table(j) = i; n_hel_unique = n_hel_unique + 1
cycle HELICITY
else if (all (hel_state(:, i) == &
hel_state(:, index_table(j)))) then
cycle HELICITY
end if
end do
end do HELICITY
allocate (qn_hel (n_tot, n_hel_unique))
allocate (hel (n_tot))
do j = 1, n_hel_unique
call hel%init (hel_state(:, index_table(j)))
call qn_hel(:, j)%init (hel)
end do
end associate
end subroutine setup_qn_hel
@ %def setup_qn_hel
@
<<Instances: term instance: TBP>>=
procedure :: init_from_process => term_instance_init_from_process
<<Instances: procedures>>=
subroutine term_instance_init_from_process (term_instance, &
process, i, pcm_instance, sf_chain)
class(term_instance_t), intent(inout), target :: term_instance
type(process_t), intent(in), target :: process
integer, intent(in) :: i
class(pcm_instance_t), intent(in), target :: pcm_instance
type(sf_chain_t), intent(in), target :: sf_chain
type(process_term_t) :: term
integer :: i_component
logical :: requires_extended_sf
term = process%get_term_ptr (i)
i_component = term%i_component
if (i_component /= 0) then
term_instance%pcm_instance => pcm_instance
term_instance%nlo_type = process%get_nlo_type_component (i_component)
requires_extended_sf = term_instance%nlo_type == NLO_DGLAP .or. &
(term_instance%nlo_type == NLO_REAL .and. process%get_i_sub (i) == i)
call term_instance%setup_kinematics (sf_chain, &
process%get_beam_config_ptr (), &
process%get_phs_config (i_component), &
requires_extended_sf)
call term_instance%init (process, i, &
real_finite = process%component_is_real_finite (i_component))
select type (phs => term_instance%k_term%phs)
type is (phs_fks_t)
call term_instance%set_emitter (process%get_pcm_ptr ())
call term_instance%setup_fks_kinematics (process%get_var_list_ptr (), &
process%get_beam_config_ptr ())
end select
call term_instance%set_threshold (process%get_pcm_ptr ())
call term_instance%setup_expressions (process%get_meta (), process%get_config ())
end if
end subroutine term_instance_init_from_process
@ %def term_instance_init_from_process
@ Initialize the seed-kinematics configuration. All subobjects are
allocated explicitly.
<<Instances: term instance: TBP>>=
procedure :: setup_kinematics => term_instance_setup_kinematics
<<Instances: procedures>>=
subroutine term_instance_setup_kinematics (term, sf_chain, &
beam_config, phs_config, extended_sf)
class(term_instance_t), intent(inout) :: term
type(sf_chain_t), intent(in), target :: sf_chain
type(process_beam_config_t), intent(in), target :: beam_config
class(phs_config_t), intent(in), target :: phs_config
logical, intent(in) :: extended_sf
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
call term%k_term%init_sf_chain (sf_chain, beam_config, &
extended_sf = config%has_pdfs .and. extended_sf)
class default
call term%k_term%init_sf_chain (sf_chain, beam_config)
end select
!!! Add one for additional Born matrix element
call term%k_term%init_phs (phs_config)
call term%k_term%set_nlo_info (term%nlo_type)
select type (phs => term%k_term%phs)
type is (phs_fks_t)
call phs%allocate_momenta (phs_config, &
.not. (term%nlo_type == NLO_REAL))
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
call config%region_data%init_phs_identifiers (phs%phs_identifiers)
!!! The triple select type pyramid of doom
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
if (allocated (pcm_instance%real_kinematics%alr_to_i_phs)) &
call config%region_data%set_alr_to_i_phs (phs%phs_identifiers, &
pcm_instance%real_kinematics%alr_to_i_phs)
end select
end select
end select
end subroutine term_instance_setup_kinematics
@ %def term_instance_setup_kinematics
@
<<Instances: term instance: TBP>>=
procedure :: setup_fks_kinematics => term_instance_setup_fks_kinematics
<<Instances: procedures>>=
subroutine term_instance_setup_fks_kinematics (term, var_list, beam_config)
class(term_instance_t), intent(inout), target :: term
type(var_list_t), intent(in) :: var_list
type(process_beam_config_t), intent(in) :: beam_config
integer :: mode
logical :: singular_jacobian
if (.not. (term%nlo_type == NLO_REAL .or. term%nlo_type == NLO_DGLAP .or. &
term%nlo_type == NLO_MISMATCH)) return
singular_jacobian = var_list%get_lval (var_str ("?powheg_use_singular_jacobian"))
if (term%nlo_type == NLO_REAL) then
mode = check_generator_mode (GEN_REAL_PHASE_SPACE)
else if (term%nlo_type == NLO_MISMATCH) then
mode = check_generator_mode (GEN_SOFT_MISMATCH)
else
mode = PHS_MODE_UNDEFINED
end if
select type (phs => term%k_term%phs)
type is (phs_fks_t)
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
call config%setup_phs_generator (pcm_instance, &
phs%generator, phs%config%sqrts, mode, singular_jacobian)
if (beam_config%has_structure_function ()) then
pcm_instance%isr_kinematics%isr_mode = SQRTS_VAR
else
pcm_instance%isr_kinematics%isr_mode = SQRTS_FIXED
end if
if (debug_on) call msg_debug (D_PHASESPACE, "isr_mode: ", pcm_instance%isr_kinematics%isr_mode)
end select
end select
class default
call msg_fatal ("Phase space should be an FKS phase space!")
end select
contains
function check_generator_mode (gen_mode_default) result (gen_mode)
integer :: gen_mode
integer, intent(in) :: gen_mode_default
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
associate (settings => config%settings)
if (settings%test_coll_limit .and. settings%test_anti_coll_limit) &
call msg_fatal ("You cannot check the collinear and anti-collinear limit "&
&"at the same time!")
if (settings%test_soft_limit .and. .not. settings%test_coll_limit &
.and. .not. settings%test_anti_coll_limit) then
gen_mode = GEN_SOFT_LIMIT_TEST
else if (.not. settings%test_soft_limit .and. settings%test_coll_limit) then
gen_mode = GEN_COLL_LIMIT_TEST
else if (.not. settings%test_soft_limit .and. settings%test_anti_coll_limit) then
gen_mode = GEN_ANTI_COLL_LIMIT_TEST
else if (settings%test_soft_limit .and. settings%test_coll_limit) then
gen_mode = GEN_SOFT_COLL_LIMIT_TEST
else if (settings%test_soft_limit .and. settings%test_anti_coll_limit) then
gen_mode = GEN_SOFT_ANTI_COLL_LIMIT_TEST
else
gen_mode = gen_mode_default
end if
end associate
end select
end function check_generator_mode
end subroutine term_instance_setup_fks_kinematics
@ %def term_instance_setup_fks_kinematics
@ Setup seed kinematics, starting from the MC parameter set given as
argument. As a result, the [[k_seed]] kinematics object is evaluated
(except for the structure-function matrix-element evaluation, which we
postpone until we know the factorization scale), and we have a valid
[[p_seed]] momentum array.
<<Instances: term instance: TBP>>=
procedure :: compute_seed_kinematics => term_instance_compute_seed_kinematics
<<Instances: procedures>>=
subroutine term_instance_compute_seed_kinematics &
(term, mci_work, phs_channel, success)
class(term_instance_t), intent(inout), target :: term
type(mci_work_t), intent(in) :: mci_work
integer, intent(in) :: phs_channel
logical, intent(out) :: success
call term%k_term%compute_selected_channel &
(mci_work, phs_channel, term%p_seed, success)
end subroutine term_instance_compute_seed_kinematics
@ %def term_instance_compute_seed_kinematics
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_radiation_kinematics => term_instance_evaluate_radiation_kinematics
<<Instances: procedures>>=
subroutine term_instance_evaluate_radiation_kinematics (term, x)
class(term_instance_t), intent(inout) :: term
real(default), dimension(:), intent(in) :: x
select type (phs => term%k_term%phs)
type is (phs_fks_t)
if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) &
call term%k_term%evaluate_radiation_kinematics (x)
end select
end subroutine term_instance_evaluate_radiation_kinematics
@ %def term_instance_evaluate_radiation_kinematics
@
<<Instances: term instance: TBP>>=
procedure :: compute_xi_ref_momenta => term_instance_compute_xi_ref_momenta
<<Instances: procedures>>=
subroutine term_instance_compute_xi_ref_momenta (term)
class(term_instance_t), intent(inout) :: term
select type (pcm => term%pcm_instance%config)
type is (pcm_nlo_t)
call term%k_term%compute_xi_ref_momenta (pcm%region_data, term%nlo_type)
end select
end subroutine term_instance_compute_xi_ref_momenta
@ %def term_instance_compute_xi_ref_momenta
@
<<Instances: term instance: TBP>>=
procedure :: generate_fsr_in => term_instance_generate_fsr_in
<<Instances: procedures>>=
subroutine term_instance_generate_fsr_in (term)
class(term_instance_t), intent(inout) :: term
select type (phs => term%k_term%phs)
type is (phs_fks_t)
call phs%generate_fsr_in ()
end select
end subroutine term_instance_generate_fsr_in
@ %def term_instance_generate_fsr_in
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_projections => term_instance_evaluate_projections
<<Instances: procedures>>=
subroutine term_instance_evaluate_projections (term)
class(term_instance_t), intent(inout) :: term
if (term%k_term%threshold .and. term%nlo_type > BORN) then
if (debug2_active (D_THRESHOLD)) &
print *, 'Evaluate on-shell projection: ', &
char (component_status (term%nlo_type))
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
call term%k_term%threshold_projection (pcm_instance, term%nlo_type)
end select
end if
end subroutine term_instance_evaluate_projections
@ %def term_instance_evaluate_projections
@
<<Instances: term instance: TBP>>=
procedure :: redo_sf_chain => term_instance_redo_sf_chain
<<Instances: procedures>>=
subroutine term_instance_redo_sf_chain (term, mci_work, phs_channel)
class(term_instance_t), intent(inout) :: term
type(mci_work_t), intent(in) :: mci_work
integer, intent(in) :: phs_channel
real(default), dimension(:), allocatable :: x
integer :: sf_channel, n
real(default) :: xi, y
n = size (mci_work%get_x_strfun ())
if (n > 0) then
allocate (x(n))
x = mci_work%get_x_strfun ()
associate (k => term%k_term)
sf_channel = k%phs%config%get_sf_channel (phs_channel)
call k%sf_chain%compute_kinematics (sf_channel, x)
deallocate (x)
end associate
end if
end subroutine term_instance_redo_sf_chain
@ %def term_instance_redo_sf_chain
@ Inverse: recover missing parts of the kinematics, given a complete
set of seed momenta. Select a channel and reconstruct the MC parameter set.
<<Instances: term instance: TBP>>=
procedure :: recover_mcpar => term_instance_recover_mcpar
<<Instances: procedures>>=
subroutine term_instance_recover_mcpar (term, mci_work, phs_channel)
class(term_instance_t), intent(inout), target :: term
type(mci_work_t), intent(inout) :: mci_work
integer, intent(in) :: phs_channel
call term%k_term%recover_mcpar (mci_work, phs_channel, term%p_seed)
end subroutine term_instance_recover_mcpar
@ %def term_instance_recover_mcpar
@ Part of [[recover_mcpar]], separately accessible. Reconstruct all
kinematics data in the structure-function chain instance.
<<Instances: term instance: TBP>>=
procedure :: recover_sfchain => term_instance_recover_sfchain
<<Instances: procedures>>=
subroutine term_instance_recover_sfchain (term, channel)
class(term_instance_t), intent(inout), target :: term
integer, intent(in) :: channel
call term%k_term%recover_sfchain (channel, term%p_seed)
end subroutine term_instance_recover_sfchain
@ %def term_instance_recover_sfchain
@ Compute the momenta in the hard interactions, one for each term that
constitutes this process component. In simple cases this amounts to
just copying momenta. In more advanced cases, we may generate
distinct sets of momenta from the seed kinematics.
The interactions in the term instances are accessed individually. We may
choose to calculate all terms at once together with the seed kinematics, use
[[component%core_state]] for storage, and just fill the interactions here.
<<Instances: term instance: TBP>>=
procedure :: compute_hard_kinematics => &
term_instance_compute_hard_kinematics
<<Instances: procedures>>=
subroutine term_instance_compute_hard_kinematics (term, skip_term, success)
class(term_instance_t), intent(inout) :: term
integer, intent(in), optional :: skip_term
logical, intent(out) :: success
type(vector4_t), dimension(:), allocatable :: p
if (allocated (term%core_state)) &
call term%core_state%reset_new_kinematics ()
if (present (skip_term)) then
if (term%config%i_term_global == skip_term) return
end if
if (term%nlo_type == NLO_REAL .and. term%k_term%emitter >= 0) then
call term%k_term%evaluate_radiation (term%p_seed, p, success)
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
if (config%dalitz_plot%active) then
if (term%k_term%emitter > term%k_term%n_in) then
if (p(term%k_term%emitter)**2 > tiny_07) &
call config%register_dalitz_plot (term%k_term%emitter, p)
end if
end if
end select
else if (is_subtraction_component (term%k_term%emitter, term%nlo_type)) then
call term%k_term%modify_momenta_for_subtraction (term%p_seed, p)
success = .true.
else
allocate (p (size (term%p_seed))); p = term%p_seed
success = .true.
end if
call term%int_hard%set_momenta (p)
end subroutine term_instance_compute_hard_kinematics
@ %def term_instance_compute_hard_kinematics
@ Here, we invert this. We fetch the incoming momenta which reside
in the appropriate [[sf_chain]] object, stored within the [[k_seed]]
subobject. On the other hand, we have the outgoing momenta of the
effective interaction. We rely on the process core to compute the
remaining seed momenta and to fill the momenta within the hard
interaction. (The latter is trivial if hard and effective interaction
coincide.)
After this is done, the incoming momenta in the trace evaluator that
corresponds to the hard (effective) interaction, are still
left undefined. We remedy this by calling [[receive_kinematics]] once.
<<Instances: term instance: TBP>>=
procedure :: recover_seed_kinematics => &
term_instance_recover_seed_kinematics
<<Instances: procedures>>=
subroutine term_instance_recover_seed_kinematics (term)
class(term_instance_t), intent(inout) :: term
integer :: n_in
n_in = term%k_term%n_in
call term%k_term%get_incoming_momenta (term%p_seed(1:n_in))
associate (int_eff => term%isolated%int_eff)
call int_eff%set_momenta (term%p_seed(1:n_in), outgoing = .false.)
term%p_seed(n_in + 1 : ) = int_eff%get_momenta (outgoing = .true.)
end associate
call term%isolated%receive_kinematics ()
end subroutine term_instance_recover_seed_kinematics
@ %def term_instance_recover_seed_kinematics
@ Compute the integration parameters for all channels except the selected
one.
<<Instances: term instance: TBP>>=
procedure :: compute_other_channels => &
term_instance_compute_other_channels
<<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.
<<Instances: term instance: TBP>>=
procedure :: return_beam_momenta => term_instance_return_beam_momenta
<<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
@
<<Instances: term instance: TBP>>=
procedure :: apply_real_partition => term_instance_apply_real_partition
<<Instances: procedures>>=
subroutine term_instance_apply_real_partition (term, process)
class(term_instance_t), intent(inout) :: term
type(process_t), intent(in) :: process
real(default) :: f, sqme
integer :: i_component
integer :: i_amp, n_amps
logical :: is_subtraction
i_component = term%config%i_component
if (process%component_is_selected (i_component) .and. &
process%get_component_nlo_type (i_component) == NLO_REAL) then
is_subtraction = process%get_component_type (i_component) == COMP_REAL_SING &
.and. term%k_term%emitter < 0
if (is_subtraction) return
select type (pcm => process%get_pcm_ptr ())
type is (pcm_nlo_t)
f = pcm%real_partition%get_f (term%p_hard)
end select
n_amps = term%connected%trace%get_n_matrix_elements ()
do i_amp = 1, n_amps
sqme = real (term%connected%trace%get_matrix_element ( &
term%connected_qn_index%get_index (i_amp, i_sub = 0)))
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_apply_real_partition")
select type (pcm => term%pcm_instance%config)
type is (pcm_nlo_t)
select case (process%get_component_type (i_component))
case (COMP_REAL_FIN, COMP_REAL_SING)
select case (process%get_component_type (i_component))
case (COMP_REAL_FIN)
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
end select
end select
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "apply_damping: sqme", sqme)
call term%connected%trace%set_matrix_element (i_amp, cmplx (sqme, zero, default))
end do
end if
end subroutine term_instance_apply_real_partition
@ %def term_instance_apply_real_partition
@
<<Instances: term instance: TBP>>=
procedure :: get_lorentz_transformation => term_instance_get_lorentz_transformation
<<Instances: procedures>>=
function term_instance_get_lorentz_transformation (term) result (lt)
type(lorentz_transformation_t) :: lt
class(term_instance_t), intent(in) :: term
lt = term%k_term%phs%get_lorentz_transformation ()
end function term_instance_get_lorentz_transformation
@ %def term_instance_get_lorentz_transformation
@
<<Instances: term instance: TBP>>=
procedure :: get_p_hard => term_instance_get_p_hard
<<Instances: procedures>>=
pure function term_instance_get_p_hard (term_instance) result (p_hard)
type(vector4_t), dimension(:), allocatable :: p_hard
class(term_instance_t), intent(in) :: term_instance
allocate (p_hard (size (term_instance%p_hard)))
p_hard = term_instance%p_hard
end function term_instance_get_p_hard
@ %def term_instance_get_p_hard
@
<<Instances: term instance: TBP>>=
procedure :: set_emitter => term_instance_set_emitter
<<Instances: procedures>>=
subroutine term_instance_set_emitter (term, pcm)
class(term_instance_t), intent(inout) :: term
class(pcm_t), intent(in) :: pcm
integer :: i_phs
logical :: set_emitter
select type (pcm)
type is (pcm_nlo_t)
!!! Without resonances, i_alr = i_phs
i_phs = term%config%i_term
term%k_term%i_phs = term%config%i_term
select type (phs => term%k_term%phs)
type is (phs_fks_t)
set_emitter = i_phs <= pcm%region_data%n_phs .and. term%nlo_type == NLO_REAL
if (set_emitter) then
term%k_term%emitter = phs%phs_identifiers(i_phs)%emitter
select type (pcm => term%pcm_instance%config)
type is (pcm_nlo_t)
if (allocated (pcm%region_data%i_phs_to_i_con)) &
term%k_term%i_con = pcm%region_data%i_phs_to_i_con (i_phs)
end select
end if
end select
end select
end subroutine term_instance_set_emitter
@ %def term_instance_set_emitter
@
<<Instances: term instance: TBP>>=
procedure :: set_threshold => term_instance_set_threshold
<<Instances: procedures>>=
subroutine term_instance_set_threshold (term, pcm)
class(term_instance_t), intent(inout) :: term
class(pcm_t), intent(in) :: pcm
select type (pcm)
type is (pcm_nlo_t)
term%k_term%threshold = pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD
class default
term%k_term%threshold = .false.
end select
end subroutine term_instance_set_threshold
@ %def term_instance_set_threshold
@ For initializing the expressions, we need the local variable list and the
parse trees.
<<Instances: term instance: TBP>>=
procedure :: setup_expressions => term_instance_setup_expressions
<<Instances: procedures>>=
subroutine term_instance_setup_expressions (term, meta, config)
class(term_instance_t), intent(inout), target :: term
type(process_metadata_t), intent(in), target :: meta
type(process_config_data_t), intent(in) :: config
if (allocated (config%ef_cuts)) &
call term%connected%setup_cuts (config%ef_cuts)
if (allocated (config%ef_scale)) &
call term%connected%setup_scale (config%ef_scale)
if (allocated (config%ef_fac_scale)) &
call term%connected%setup_fac_scale (config%ef_fac_scale)
if (allocated (config%ef_ren_scale)) &
call term%connected%setup_ren_scale (config%ef_ren_scale)
if (allocated (config%ef_weight)) &
call term%connected%setup_weight (config%ef_weight)
end subroutine term_instance_setup_expressions
@ %def term_instance_setup_expressions
@ Prepare the extra evaluators that we need for processing events.
The quantum numbers mask of the incoming particle
<<Instances: term instance: TBP>>=
procedure :: setup_event_data => term_instance_setup_event_data
<<Instances: procedures>>=
subroutine term_instance_setup_event_data (term, core, model)
class(term_instance_t), intent(inout), target :: term
class(prc_core_t), intent(in) :: core
class(model_data_t), intent(in), target :: model
integer :: n_in
type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
n_in = term%int_hard%get_n_in ()
allocate (mask_in (n_in))
mask_in = term%k_term%sf_chain%get_out_mask ()
call setup_isolated (term%isolated, core, model, mask_in, term%config%col)
call setup_connected (term%connected, term%isolated, term%nlo_type)
contains
subroutine setup_isolated (isolated, core, model, mask, color)
type(isolated_state_t), intent(inout), target :: isolated
class(prc_core_t), intent(in) :: core
class(model_data_t), intent(in), target :: model
type(quantum_numbers_mask_t), intent(in), dimension(:) :: mask
integer, intent(in), dimension(:) :: color
call isolated%setup_square_matrix (core, model, mask, color)
call isolated%setup_square_flows (core, model, mask)
end subroutine setup_isolated
subroutine setup_connected (connected, isolated, nlo_type)
type(connected_state_t), intent(inout), target :: connected
type(isolated_state_t), intent(in), target :: isolated
integer :: nlo_type
type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
call connected%setup_connected_matrix (isolated)
if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL &
.and. term%config%i_term_global == term%config%i_sub) &
.or. term%nlo_type == NLO_DGLAP) then
!!! We don't care about the subtraction matrix elements in
!!! connected%matrix, because all entries there are supposed
!!! to be squared. To be able to match with flavor quantum numbers,
!!! we remove the subtraction quantum entries from the state matrix.
allocate (mask (connected%matrix%get_n_tot()))
call mask%set_sub (1)
call connected%matrix%reduce_state_matrix (mask, keep_order = .true.)
end if
call connected%setup_connected_flows (isolated)
call connected%setup_state_flv (isolated%get_n_out ())
end subroutine setup_connected
end subroutine term_instance_setup_event_data
@ %def term_instance_setup_event_data
@ Color-correlated matrix elements should be obtained from
the external BLHA provider. According to the standard, the
matrix elements output is a one-dimensional array. For FKS
subtraction, we require the matrix $B_{ij}$. BLHA prescribes
a mapping $(i, j) \to k$, where $k$ is the index of the matrix
element in the output array. It focusses on the off-diagonal entries,
i.e. $i \neq j$. The subroutine [[blha_color_c_fill_offdiag]] realizes
this mapping. The diagonal entries can simply be obtained as
the product of the Born matrix element and either $C_A$ or $C_F$,
which is achieved by [[blha_color_c_fill_diag]].
For simple processes, i.e. those with only one color line, it is
$B_{ij} = C_F \cdot B$. For those, we keep the possibility of computing
color correlations by a multiplication of the Born matrix element with $C_F$.
It is triggered by the [[use_internal_color_correlations]] flag and should
be used only for testing purposes. However, it is also used for
the threshold computation where the process is well-defined and fixed.
<<Instances: term instance: TBP>>=
procedure :: evaluate_color_correlations => &
term_instance_evaluate_color_correlations
<<Instances: procedures>>=
subroutine term_instance_evaluate_color_correlations (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
integer :: i_flv_born
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
if (debug_on) call msg_debug2 (D_SUBTRACTION, &
"term_instance_evaluate_color_correlations: " // &
"use_internal_color_correlations:", &
config%settings%use_internal_color_correlations)
if (debug_on) call msg_debug2 (D_SUBTRACTION, "fac_scale", term%fac_scale)
do i_flv_born = 1, config%region_data%n_flv_born
select case (term%nlo_type)
case (NLO_REAL)
call transfer_me_array_to_bij (config, i_flv_born, &
pcm_instance%real_sub%sqme_born (i_flv_born), &
pcm_instance%real_sub%sqme_born_color_c (:, :, i_flv_born))
case (NLO_MISMATCH)
call transfer_me_array_to_bij (config, i_flv_born, &
pcm_instance%soft_mismatch%sqme_born (i_flv_born), &
pcm_instance%soft_mismatch%sqme_born_color_c (:, :, i_flv_born))
case (NLO_VIRTUAL)
!!! This is just a copy of the above with a different offset and can for sure be unified
call transfer_me_array_to_bij (config, i_flv_born, &
-one, pcm_instance%virtual%sqme_color_c (:, :, i_flv_born))
end select
end do
end select
end select
contains
function get_trivial_cf_factors (n_tot, flv, factorization_mode) result (beta_ij)
integer, intent(in) :: n_tot, factorization_mode
integer, intent(in), dimension(:) :: flv
real(default), dimension(n_tot, n_tot) :: beta_ij
if (factorization_mode == NO_FACTORIZATION) then
beta_ij = get_trivial_cf_factors_default (n_tot, flv)
else
beta_ij = get_trivial_cf_factors_threshold (n_tot, flv)
end if
end function get_trivial_cf_factors
function get_trivial_cf_factors_default (n_tot, flv) result (beta_ij)
integer, intent(in) :: n_tot
integer, intent(in), dimension(:) :: flv
real(default), dimension(n_tot, n_tot) :: beta_ij
integer :: i, j
beta_ij = zero
if (count (is_quark (flv)) == 2) then
do i = 1, n_tot
do j = 1, n_tot
if (is_quark(flv(i)) .and. is_quark(flv(j))) then
if (i == j) then
beta_ij(i,j)= -cf
else
beta_ij(i,j) = cf
end if
end if
end do
end do
end if
end function get_trivial_cf_factors_default
function get_trivial_cf_factors_threshold (n_tot, flv) result (beta_ij)
integer, intent(in) :: n_tot
integer, intent(in), dimension(:) :: flv
real(default), dimension(n_tot, n_tot) :: beta_ij
integer :: i
beta_ij = zero
do i = 1, 4
beta_ij(i,i) = -cf
end do
beta_ij(1,2) = cf; beta_ij(2,1) = cf
beta_ij(3,4) = cf; beta_ij(4,3) = cf
end function get_trivial_cf_factors_threshold
subroutine transfer_me_array_to_bij (pcm, i_flv, &
sqme_born, sqme_color_c)
type(pcm_nlo_t), intent(in) :: pcm
integer, intent(in) :: i_flv
real(default), intent(in) :: sqme_born
real(default), dimension(:,:), intent(inout) :: sqme_color_c
integer :: i_color_c, i_sub, n_pdf_off, virt_off, n_offset
real(default), dimension(:), allocatable :: sqme
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
n_offset = 0
if (term%nlo_type == NLO_VIRTUAL) then
n_offset = 1
else if (pcm%has_pdfs .and. term%is_subtraction ()) then
n_offset = n_beam_structure_int
end if
allocate (sqme (term%get_n_sub_color ()), source = zero)
do i_sub = 1, term%get_n_sub_color ()
sqme(i_sub) = real(term%connected%trace%get_matrix_element ( &
term%connected_qn_index%get_index (i_flv, i_sub = i_sub + n_offset)), default)
end do
call blha_color_c_fill_offdiag (pcm%region_data%n_legs_born, &
sqme, sqme_color_c)
call blha_color_c_fill_diag (real(term%connected%trace%get_matrix_element ( &
term%connected_qn_index%get_index (i_flv, i_sub = 0)), default), &
pcm%region_data%get_flv_states_born (i_flv), &
sqme_color_c)
end if
end subroutine transfer_me_array_to_bij
end subroutine term_instance_evaluate_color_correlations
@ %def term_instance_evaluate_color_correlations
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_charge_correlations => &
term_instance_evaluate_charge_correlations
<<Instances: procedures>>=
subroutine term_instance_evaluate_charge_correlations (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
integer :: i_flv_born
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
do i_flv_born = 1, config%region_data%n_flv_born
select case (term%nlo_type)
case (NLO_REAL)
call transfer_me_array_to_bij (config, i_flv_born, &
pcm_instance%real_sub%sqme_born (i_flv_born), &
pcm_instance%real_sub%sqme_born_charge_c (:, :, i_flv_born))
case (NLO_MISMATCH)
call transfer_me_array_to_bij (config, i_flv_born, &
pcm_instance%soft_mismatch%sqme_born (i_flv_born), &
pcm_instance%soft_mismatch%sqme_born_charge_c (:, :, i_flv_born))
case (NLO_VIRTUAL)
call transfer_me_array_to_bij (config, i_flv_born, &
-one, pcm_instance%virtual%sqme_charge_c (:, :, i_flv_born))
end select
end do
end select
end select
contains
subroutine transfer_me_array_to_bij (pcm, i_flv, sqme_born, sqme_charge_c)
type(pcm_nlo_t), intent(in) :: pcm
integer, intent(in) :: i_flv
real(default), intent(in) :: sqme_born
real(default), dimension(:,:), intent(inout) :: sqme_charge_c
integer :: n_legs_born, i, j
integer, dimension(:), allocatable :: sigma
real(default), dimension(:), allocatable :: Q
n_legs_born = pcm%region_data%n_legs_born
associate (flv_born => pcm%region_data%flv_born(i_flv))
allocate (sigma (n_legs_born), Q (size (flv_born%charge)))
Q = flv_born%charge
sigma(1:flv_born%n_in) = sign (1, flv_born%flst(1:flv_born%n_in))
sigma(flv_born%n_in + 1: ) = -sign (1, flv_born%flst(flv_born%n_in + 1: ))
end associate
do i = 1, n_legs_born
do j = 1, n_legs_born
sqme_charge_c(i, j) = sigma(i) * sigma(j) * Q(i) * Q(j) * (-one)
end do
end do
sqme_charge_c = sqme_charge_c * sqme_born
end subroutine transfer_me_array_to_bij
end subroutine term_instance_evaluate_charge_correlations
@ %def term_instance_evaluate_charge_correlations
@ The information about spin correlations is not stored in the [[nlo_settings]] because
it is only available after the [[fks_regions]] have been created.
<<Instances: term instance: TBP>>=
procedure :: evaluate_spin_correlations => term_instance_evaluate_spin_correlations
<<Instances: procedures>>=
subroutine term_instance_evaluate_spin_correlations (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
integer :: i_flv, i_hel, i_sub, i_emitter, emitter
integer :: n_flv, n_sub_color, n_sub_spin, n_offset
real(default), dimension(0:3, 0:3) :: sqme_spin_c
real(default), dimension(:), allocatable :: sqme_spin_c_all
real(default), dimension(:), allocatable :: sqme_spin_c_arr
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
"term_instance_evaluate_spin_correlations")
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
if (pcm_instance%real_sub%requires_spin_correlations () &
.and. term%nlo_type == NLO_REAL) then
select type (core)
type is (prc_openloops_t)
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
n_flv = term%connected_qn_index%get_n_flv ()
n_sub_color = term%get_n_sub_color ()
n_sub_spin = term%get_n_sub_spin ()
n_offset = 0; if(config%has_pdfs) n_offset = n_beam_structure_int
allocate (sqme_spin_c_arr(16))
do i_flv = 1, n_flv
allocate (sqme_spin_c_all(n_sub_spin))
do i_sub = 1, n_sub_spin
sqme_spin_c_all(i_sub) = real(term%connected%trace%get_matrix_element &
(term%connected_qn_index%get_index (i_flv, &
i_sub = i_sub + n_offset + n_sub_color)), default)
end do
do i_emitter = 1, config%region_data%n_emitters
emitter = config%region_data%emitters(i_emitter)
if (emitter > 0) then
call split_array (sqme_spin_c_all, sqme_spin_c_arr)
sqme_spin_c = reshape (sqme_spin_c_arr, (/4,4/))
pcm_instance%real_sub%sqme_born_spin_c(:,:,emitter,i_flv) = sqme_spin_c
end if
end do
deallocate (sqme_spin_c_all)
end do
end select
class default
call msg_fatal ("Spin correlations so far only supported by OpenLoops.")
end select
end if
end select
end subroutine term_instance_evaluate_spin_correlations
@ %def term_instance_evaluate_spin_correlations
@ Compute collinear ISR from interactions, real component and DLGAP remnant are
handled accordingly.
<<Instances: term instance: TBP>>=
procedure :: compute_sqme_coll_isr => term_instance_compute_sqme_coll_isr
<<Instances: procedures>>=
subroutine term_instance_compute_sqme_coll_isr (term)
class(term_instance_t), intent(in) :: term
integer :: i_flv
integer, parameter :: BEAM_PLUS = 1, BEAM_MINUS = 2, &
PDF = 1, PDF_SINGLET = 2
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
select type (pcm => term%pcm_instance%config)
type is (pcm_nlo_t)
associate (me => term%connected%trace%get_matrix_element ())
do i_flv = 1, pcm%region_data%n_flv_born
call set_sqme_coll_isr (BEAM_PLUS, PDF, i_flv, &
real(me(term%connected_qn_index%get_index (i_flv, i_sub = 1))))
call set_sqme_coll_isr (BEAM_MINUS, PDF, i_flv, &
real(me(term%connected_qn_index%get_index (i_flv, i_sub = 2))))
if (pcm%settings%nlo_correction_type == "QCD" .or. &
pcm%settings%nlo_correction_type == "Full") then
call set_sqme_coll_isr (BEAM_PLUS, PDF_SINGLET, i_flv, &
real(me(term%connected_qn_index%get_index (i_flv, i_sub = 3))))
call set_sqme_coll_isr (BEAM_MINUS, PDF_SINGLET, i_flv, &
real(me(term%connected_qn_index%get_index (i_flv, i_sub = 4))))
end if
end do
end associate
if (debug2_active (D_BEAMS)) then
call msg_debug2 (D_BEAMS, "term_instance_compute_sqme_coll_isr")
if (term%nlo_type == NLO_REAL) then
print *, "nlo_type: REAL"
print *, "n_flv: ", pcm%region_data%n_flv_born
print *, "i_flv: ", i_flv
print *, "Beam 1: "
print *, " quarks: ", pcm_instance%real_sub%sqme_coll_isr (BEAM_PLUS, PDF, :)
print *, " gluon: ", pcm_instance%real_sub%sqme_coll_isr (BEAM_PLUS, PDF_SINGLET, :)
print *, "Beam 2: "
print *, " quarks: ", pcm_instance%real_sub%sqme_coll_isr (BEAM_MINUS, PDF, :)
print *, " gluon: ", pcm_instance%real_sub%sqme_coll_isr (BEAM_MINUS, PDF_SINGLET, :)
else if (term%nlo_type == NLO_DGLAP) then
print *, "nlo_type: DGLAP"
print *, "n_flv: ", pcm%region_data%n_flv_born
print *, "i_flv: ", i_flv
print *, "Beam 1: "
print *, " quarks: ", pcm_instance%dglap_remnant%sqme_coll_isr (BEAM_PLUS, PDF, :)
print *, " gluon: ", pcm_instance%dglap_remnant%sqme_coll_isr (BEAM_PLUS, PDF_SINGLET, :)
print *, "Beam 2: "
print *, " quarks: ", pcm_instance%dglap_remnant%sqme_coll_isr (BEAM_MINUS, PDF, :)
print *, " gluon: ", pcm_instance%dglap_remnant%sqme_coll_isr (BEAM_MINUS, PDF_SINGLET, :)
end if
end if
end select
end select
contains
subroutine set_sqme_coll_isr (i_beam, i_type, i_flv, me)
integer, intent(in) :: i_beam, i_type, i_flv
real(default), intent(in) :: me
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
select case (term%nlo_type)
case (NLO_REAL)
pcm_instance%real_sub%sqme_coll_isr (i_beam, i_type, i_flv) = me
case (NLO_DGLAP)
pcm_instance%dglap_remnant%sqme_coll_isr (i_beam, i_type, i_flv) = me
end select
end select
end subroutine set_sqme_coll_isr
end subroutine term_instance_compute_sqme_coll_isr
@ %def term_instance_compute_sqme_coll_isr
@
<<Instances: term instance: TBP>>=
procedure :: apply_fks => term_instance_apply_fks
<<Instances: procedures>>=
subroutine term_instance_apply_fks (term, alpha_s_sub, alpha_qed_sub)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_s_sub, alpha_qed_sub
real(default), dimension(:), allocatable :: sqme
integer :: i, i_phs, emitter
logical :: is_subtraction
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
select type (config => pcm_instance%config)
type is (pcm_nlo_t)
if (term%connected%has_matrix) then
allocate (sqme (config%get_n_alr ()))
else
allocate (sqme (1))
end if
sqme = zero
select type (phs => term%k_term%phs)
type is (phs_fks_t)
call pcm_instance%set_real_and_isr_kinematics &
(phs%phs_identifiers, term%k_term%phs%get_sqrts ())
if (term%k_term%emitter < 0) then
call pcm_instance%set_subtraction_event ()
do i_phs = 1, config%region_data%n_phs
emitter = phs%phs_identifiers(i_phs)%emitter
call pcm_instance%real_sub%compute (emitter, &
i_phs, alpha_s_sub, alpha_qed_sub, term%connected%has_matrix, sqme)
end do
else
call pcm_instance%set_radiation_event ()
emitter = term%k_term%emitter; i_phs = term%k_term%i_phs
do i = 1, term%connected_qn_index%get_n_flv ()
pcm_instance%real_sub%sqme_real_non_sub (i, i_phs) = &
real (term%connected%trace%get_matrix_element ( &
term%connected_qn_index%get_index (i)))
end do
call pcm_instance%real_sub%compute (emitter, i_phs, alpha_s_sub, &
alpha_qed_sub, term%connected%has_matrix, sqme)
end if
end select
end select
end select
if (term%connected%has_trace) &
call term%connected%trace%set_only_matrix_element &
(1, cmplx (sum(sqme), 0, default))
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
is_subtraction = term%k_term%emitter < 0
if (term%connected%has_matrix) &
call refill_evaluator (cmplx (sqme, 0, default), &
config%get_qn (is_subtraction), &
config%region_data%get_flavor_indices (is_subtraction), &
term%connected%matrix)
if (term%connected%has_flows) &
call refill_evaluator (cmplx (sqme, 0, default), &
config%get_qn (is_subtraction), &
config%region_data%get_flavor_indices (is_subtraction), &
term%connected%flows)
end select
end subroutine term_instance_apply_fks
@ %def term_instance_apply_fks
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_sqme_virt => term_instance_evaluate_sqme_virt
<<Instances: procedures>>=
subroutine term_instance_evaluate_sqme_virt (term, alpha_s, alpha_qed)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_s, alpha_qed
real(default) :: alpha_coupling
type(vector4_t), dimension(:), allocatable :: p_born
real(default), dimension(:), allocatable :: sqme_virt
integer :: i_flv
if (term%nlo_type /= NLO_VIRTUAL) call msg_fatal &
("Trying to evaluate virtual matrix element with unsuited term_instance.")
if (debug2_active (D_VIRTUAL)) then
call msg_debug2 (D_VIRTUAL, "Evaluating virtual-subtracted matrix elements")
print *, 'ren_scale: ', term%ren_scale
print *, 'fac_scale: ', term%fac_scale
end if
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
associate (nlo_corr_type => config%region_data%regions(1)%nlo_correction_type)
if (nlo_corr_type == "QCD") then
alpha_coupling = alpha_s
if (debug2_active (D_VIRTUAL)) print *, 'alpha_s: ', alpha_coupling
else if (nlo_corr_type == "QED") then
alpha_coupling = alpha_qed
if (debug2_active (D_VIRTUAL)) print *, 'alpha_qed: ', alpha_coupling
end if
end associate
allocate (p_born (config%region_data%n_legs_born))
if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
p_born = pcm_instance%real_kinematics%p_born_onshell%get_momenta(1)
else
p_born = term%int_hard%get_momenta ()
end if
call pcm_instance%set_momenta_and_scales_virtual &
(p_born, term%ren_scale, term%fac_scale)
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
associate (virtual => pcm_instance%virtual)
do i_flv = 1, term%connected_qn_index%get_n_flv ()
virtual%sqme_born(i_flv) = &
real (term%connected%trace%get_matrix_element ( &
term%connected_qn_index%get_index (i_flv, i_sub = 0)))
virtual%sqme_virt_fin(i_flv) = &
real (term%connected%trace%get_matrix_element ( &
term%connected_qn_index%get_index (i_flv, i_sub = 1)))
end do
end associate
end select
call pcm_instance%compute_sqme_virt (term%p_hard, alpha_coupling, &
term%connected%has_matrix, sqme_virt)
call term%connected%trace%set_only_matrix_element &
(1, cmplx (sum(sqme_virt) * term%weight, 0, default))
if (term%connected%has_matrix) then
call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), &
config%get_qn (.true.), &
config%region_data%get_flavor_indices (.true.), &
term%connected%matrix)
end if
end select
end select
end subroutine term_instance_evaluate_sqme_virt
@ %def term_instance_evaluate_sqme_virt
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_sqme_mismatch => term_instance_evaluate_sqme_mismatch
<<Instances: procedures>>=
subroutine term_instance_evaluate_sqme_mismatch (term, alpha_s)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_s
real(default), dimension(:), allocatable :: sqme_mism
if (term%nlo_type /= NLO_MISMATCH) call msg_fatal &
("Trying to evaluate soft mismatch with unsuited term_instance.")
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
call pcm_instance%compute_sqme_mismatch &
(alpha_s, term%connected%has_matrix, sqme_mism)
end select
call term%connected%trace%set_only_matrix_element &
(1, cmplx (sum (sqme_mism) * term%weight, 0, default))
if (term%connected%has_matrix) then
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), &
config%get_qn (.true.), config%region_data%get_flavor_indices (.true.), &
term%connected%matrix)
end select
end if
end subroutine term_instance_evaluate_sqme_mismatch
@ %def term_instance_evaluate_sqme_mismatch
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_sqme_dglap => term_instance_evaluate_sqme_dglap
<<Instances: procedures>>=
subroutine term_instance_evaluate_sqme_dglap (term, alpha_s)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_s
real(default), dimension(:), allocatable :: sqme_dglap
integer :: i_flv
if (term%nlo_type /= NLO_DGLAP) call msg_fatal &
("Trying to evaluate DGLAP remnant with unsuited term_instance.")
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_evaluate_sqme_dglap")
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
if (debug2_active (D_PROCESS_INTEGRATION)) then
associate (n_flv => pcm_instance%dglap_remnant%n_flv)
print *, "size(sqme_born) = ", size (pcm_instance%dglap_remnant%sqme_born)
call term%connected%trace%write ()
do i_flv = 1, n_flv
print *, "i_flv = ", i_flv, ", n_flv = ", n_flv
print *, "sqme_born(i_flv) = ", pcm_instance%dglap_remnant%sqme_born(i_flv)
end do
end associate
end if
call pcm_instance%compute_sqme_dglap_remnant (alpha_s, &
term%connected%has_matrix, sqme_dglap)
end select
call term%connected%trace%set_only_matrix_element &
(1, cmplx (sum (sqme_dglap) * term%weight, 0, default))
if (term%connected%has_matrix) then
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), &
config%get_qn (.true.), &
config%region_data%get_flavor_indices (.true.), &
term%connected%matrix)
end select
end if
end subroutine term_instance_evaluate_sqme_dglap
@ %def term_instance_evaluate_sqme_dglap
@ Reset the term instance: clear the parton-state expressions and deactivate.
<<Instances: term instance: TBP>>=
procedure :: reset => term_instance_reset
<<Instances: procedures>>=
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: procedures>>=
subroutine term_instance_set_alpha_qcd_forced (term, alpha_qcd)
class(term_instance_t), intent(inout) :: term
real(default), intent(in) :: alpha_qcd
if (allocated (term%alpha_qcd_forced)) then
term%alpha_qcd_forced = alpha_qcd
else
allocate (term%alpha_qcd_forced, source = alpha_qcd)
end if
end subroutine term_instance_set_alpha_qcd_forced
@ %def term_instance_set_alpha_qcd_forced
@ Complete the kinematics computation for the effective parton states.
We assume that the [[compute_hard_kinematics]] method of the process
component instance has already been called, so the [[int_hard]]
contains the correct hard kinematics. The duty of this procedure is
first to compute the effective kinematics and store this in the
[[int_eff]] effective interaction inside the [[isolated]] parton
state. The effective kinematics may differ from the kinematics in the hard
interaction. It may involve parton recombination or parton splitting.
The [[rearrange_partons]] method is responsible for this part.
We may also call a method to compute the effective structure-function
chain at this point. This is not implemented yet.
In the simple case that no rearrangement is necessary, as indicated by
the [[rearrange]] flag, the effective interaction is a pointer to the
hard interaction, and we can skip the rearrangement method. Similarly
for the effective structure-function chain. (If we have an algorithm
that uses rarrangement, it should evaluate [[k_term]] explicitly.)
The final step of kinematics setup is to transfer the effective
kinematics to the evaluators and to the [[subevt]].
<<Instances: term instance: TBP>>=
procedure :: compute_eff_kinematics => &
term_instance_compute_eff_kinematics
<<Instances: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine term_instance_evaluate_expressions (term, scale_forced)
class(term_instance_t), intent(inout) :: term
real(default), intent(in), allocatable, optional :: scale_forced
call term%connected%evaluate_expressions (term%passed, &
term%scale, term%fac_scale, term%ren_scale, term%weight, &
scale_forced, force_evaluation = .true.)
term%checked = .true.
end subroutine term_instance_evaluate_expressions
@ %def term_instance_evaluate_expressions
@ Evaluate the trace: first evaluate the hard interaction, then the trace
evaluator. We use the [[evaluate_interaction]] method of the process
component which generated this term. The [[subevt]] and cut expressions are
not yet filled.
The [[component]] argument is intent(inout) because the [[compute_amplitude]]
method may modify the [[core_state]] workspace object.
<<Instances: term instance: TBP>>=
procedure :: evaluate_interaction => term_instance_evaluate_interaction
<<Instances: procedures>>=
subroutine term_instance_evaluate_interaction (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(in), pointer :: core
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
"term_instance_evaluate_interaction")
term%p_hard = term%int_hard%get_momenta ()
select type (core)
class is (prc_external_t)
call term%evaluate_interaction_userdef (core)
class default
call term%evaluate_interaction_default (core)
end select
call term%int_hard%set_matrix_element (term%amp)
end subroutine term_instance_evaluate_interaction
@ %def term_instance_evaluate_interaction
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_interaction_default &
=> term_instance_evaluate_interaction_default
<<Instances: procedures>>=
subroutine term_instance_evaluate_interaction_default (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(in) :: core
integer :: i
do i = 1, term%config%n_allowed
term%amp(i) = core%compute_amplitude (term%config%i_term, term%p_hard, &
term%config%flv(i), term%config%hel(i), term%config%col(i), &
term%fac_scale, term%ren_scale, term%alpha_qcd_forced, &
term%core_state)
end do
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
call pcm_instance%set_fac_scale (term%fac_scale)
end select
end subroutine term_instance_evaluate_interaction_default
@ %def term_instance_evaluate_interaction_default
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_interaction_userdef &
=> term_instance_evaluate_interaction_userdef
<<Instances: procedures>>=
subroutine term_instance_evaluate_interaction_userdef (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
"term_instance_evaluate_interaction_userdef")
select type (core_state => term%core_state)
type is (openloops_state_t)
select type (core)
type is (prc_openloops_t)
call core%compute_alpha_s (core_state, term%ren_scale)
if (allocated (core_state%threshold_data)) &
call evaluate_threshold_parameters (core_state, core, term%k_term%phs%get_sqrts ())
end select
class is (prc_external_state_t)
select type (core)
class is (prc_external_t)
call core%compute_alpha_s (core_state, term%ren_scale)
end select
end select
call evaluate_threshold_interaction ()
if (term%nlo_type == NLO_VIRTUAL) then
call term%evaluate_interaction_userdef_loop (core)
else
call term%evaluate_interaction_userdef_tree (core)
end if
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
call pcm_instance%set_fac_scale (term%fac_scale)
end select
contains
subroutine evaluate_threshold_parameters (core_state, core, sqrts)
type(openloops_state_t), intent(inout) :: core_state
type(prc_openloops_t), intent(inout) :: core
real(default), intent(in) :: sqrts
real(default) :: mtop, wtop
mtop = m1s_to_mpole (sqrts)
wtop = core_state%threshold_data%compute_top_width &
(mtop, core_state%alpha_qcd)
call core%set_mass_and_width (6, mtop, wtop)
end subroutine
subroutine evaluate_threshold_interaction ()
integer :: leg
select type (core)
type is (prc_threshold_t)
if (term%nlo_type > BORN) then
select type (pcm => term%pcm_instance)
type is (pcm_instance_nlo_t)
if (term%k_term%emitter >= 0) then
call core%set_offshell_momenta &
(pcm%real_kinematics%p_real_cms%get_momenta(term%config%i_term))
leg = thr_leg (term%k_term%emitter)
call core%set_leg (leg)
call core%set_onshell_momenta &
(pcm%real_kinematics%p_real_onshell(leg)%get_momenta(term%config%i_term))
else
call core%set_leg (0)
call core%set_offshell_momenta &
(pcm%real_kinematics%p_born_cms%get_momenta(1))
end if
end select
else
call core%set_leg (-1)
call core%set_offshell_momenta (term%p_hard)
end if
end select
end subroutine evaluate_threshold_interaction
end subroutine term_instance_evaluate_interaction_userdef
@ %def term_instance_evaluate_interaction_userdef
@ Retrieve the matrix elements from a matrix element provider and place them
into [[term%amp]].
For the handling of NLO calculations, FKS applies a book keeping handling
flavor and/or particle type (e.g. for QCD: quark/gluon and quark flavor) in
order to calculate the subtraction terms. Therefore, we have to insert the
calculated matrix elements correctly into the state matrix where each entry
corresponds to a set of quantum numbers. We apply a mapping [[hard_qn_ind]] from a list of
quantum numbers provided by FKS to the hard process [[int_hard]].
The calculated matrix elements are insert into [[term%amp]] in the following
way. The first [[n_born]] particles are the matrix element of the hard process.
In non-trivial beams, we store another [[n_beam_structure_int]] copies of these
matrix elements as the first [[n_beam_structure_int]] subtractions.
The next $n_{\text{born}}\times n_{sub}$ are color-correlated born matrix elements.
<<Instances: term instance: TBP>>=
procedure :: evaluate_interaction_userdef_tree &
=> term_instance_evaluate_interaction_userdef_tree
<<Instances: procedures>>=
subroutine term_instance_evaluate_interaction_userdef_tree (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(inout) :: core
real(default) :: sqme
real(default), dimension(:), allocatable :: sqme_color_c
real(default), dimension(:), allocatable :: sqme_spin_c
real(default), dimension(16) :: sqme_spin_c_tmp
integer :: n_flv, n_hel, n_sub_color, n_sub_spin, n_pdf_off
integer :: i_flv, i_hel, i_sub, i_color_c, i_spin_c, i_emitter
integer :: emitter
logical :: bad_point, bp
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
"term_instance_evaluate_interaction_userdef_tree")
allocate (sqme_color_c (blha_result_array_size &
(term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C)))
n_flv = term%hard_qn_index%get_n_flv ()
n_hel = term%hard_qn_index%get_n_hel ()
n_sub_color = term%get_n_sub_color ()
n_sub_spin = term%get_n_sub_spin ()
do i_flv = 1, n_flv
do i_hel = 1, n_hel
select type (core)
class is (prc_external_t)
call core%update_alpha_s (term%core_state, term%ren_scale)
call core%compute_sqme (i_flv, i_hel, term%p_hard, term%ren_scale, &
sqme, bad_point)
call term%pcm_instance%set_bad_point (bad_point)
associate (i_int => term%hard_qn_index%get_index (i_flv = i_flv, i_hel = i_hel, i_sub = 0))
term%amp(i_int) = cmplx (sqme, 0, default)
end associate
end select
n_pdf_off = 0
if (term%pcm_instance%config%has_pdfs .and. &
(term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then
n_pdf_off = n_pdf_off + n_beam_structure_int
do i_sub = 1, n_pdf_off
term%amp(term%hard_qn_index%get_index (i_flv, i_hel, i_sub)) = &
term%amp(term%hard_qn_index%get_index (i_flv, i_hel, i_sub = 0))
end do
end if
if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. &
term%nlo_type == NLO_MISMATCH) then
sqme_color_c = zero
select type (core)
class is (prc_blha_t)
call core%compute_sqme_color_c_raw (i_flv, i_hel, &
term%p_hard, term%ren_scale, sqme_color_c, bad_point)
call term%pcm_instance%set_bad_point (bad_point)
class is (prc_recola_t)
call core%compute_sqme_color_c_raw (i_flv, i_hel, &
term%p_hard, term%ren_scale, sqme_color_c, bad_point)
call term%pcm_instance%set_bad_point (bad_point)
end select
do i_sub = 1, n_sub_color
i_color_c = term%hard_qn_index%get_index &
(i_flv, i_hel, i_sub + n_pdf_off)
term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default)
end do
if (n_sub_spin > 0) then
bad_point = .false.
allocate (sqme_spin_c(0))
select type (core)
type is (prc_openloops_t)
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
do i_emitter = 1, config%region_data%n_emitters
emitter = config%region_data%emitters(i_emitter)
if (emitter > 0) then
call core%compute_sqme_spin_c &
(i_flv, &
i_hel, &
emitter, &
term%p_hard, &
term%ren_scale, &
sqme_spin_c_tmp, &
bp)
sqme_spin_c = [sqme_spin_c, sqme_spin_c_tmp]
bad_point = bad_point .or. bp
end if
end do
end select
do i_sub = 1, n_sub_spin
i_spin_c = term%hard_qn_index%get_index (i_flv, i_hel, &
i_sub + n_pdf_off + n_sub_color)
term%amp(i_spin_c) = cmplx &
(sqme_spin_c(i_sub), 0, default)
end do
end select
deallocate (sqme_spin_c)
end if
end if
end do
end do
end subroutine term_instance_evaluate_interaction_userdef_tree
@ %def term_instance_evaluate_interaction_userdef_tree
@
<<Instances: term instance: TBP>>=
procedure :: evaluate_interaction_userdef_loop &
=> term_instance_evaluate_interaction_userdef_loop
<<Instances: procedures>>=
subroutine term_instance_evaluate_interaction_userdef_loop (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(in) :: core
integer :: n_hel, n_sub, n_flv
integer :: i, i_flv, i_hel, i_sub, i_virt, i_color_c
real(default), dimension(4) :: sqme_virt
real(default), dimension(:), allocatable :: sqme_color_c
logical :: bad_point
if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
"term_instance_evaluate_interaction_userdef_loop")
allocate (sqme_color_c (blha_result_array_size &
(term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C)))
n_flv = term%hard_qn_index%get_n_flv ()
n_hel = term%hard_qn_index%get_n_hel ()
n_sub = term%hard_qn_index%get_n_sub ()
i_virt = 1
do i_flv = 1, n_flv
do i_hel = 1, n_hel
select type (core)
class is (prc_external_t)
call core%compute_sqme_virt (i_flv, i_hel, term%p_hard, &
term%ren_scale, sqme_virt, bad_point)
call term%pcm_instance%set_bad_point (bad_point)
end select
associate (i_born => term%hard_qn_index%get_index (i_flv, i_hel = i_hel, i_sub = 0), &
i_loop => term%hard_qn_index%get_index (i_flv, i_hel = i_hel, i_sub = i_virt))
term%amp(i_loop) = cmplx (sqme_virt(3), 0, default)
term%amp(i_born) = cmplx (sqme_virt(4), 0, default)
end associate
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
select type (core)
class is (prc_blha_t)
call core%compute_sqme_color_c_raw (i_flv, i_hel, &
term%p_hard, term%ren_scale, &
sqme_color_c, bad_point)
call term%pcm_instance%set_bad_point (bad_point)
do i_sub = 1 + i_virt, n_sub
i_color_c = term%hard_qn_index%get_index &
(i_flv, i_hel = i_hel, i_sub = i_sub)
! Index shift: i_sub - i_virt
term%amp(i_color_c) = &
cmplx (sqme_color_c(i_sub - i_virt), 0, default)
end do
type is (prc_recola_t)
call core%compute_sqme_color_c_raw (i_flv, i_hel, &
term%p_hard, term%ren_scale, sqme_color_c, bad_point)
call term%pcm_instance%set_bad_point (bad_point)
do i_sub = 1 + i_virt, n_sub
i_color_c = term%hard_qn_index%get_index &
(i_flv, i_hel = i_hel, i_sub = i_sub)
! Index shift: i_sub - i_virt
term%amp(i_color_c) = &
cmplx (sqme_color_c(i_sub - i_virt), 0, default)
end do
end select
end select
end do
end do
end subroutine term_instance_evaluate_interaction_userdef_loop
@ %def term_instance_evaluate_interaction_userdef_loop
@ Evaluate the trace. First evaluate the
structure-function chain (i.e., the density matrix of the incoming
partons). Do this twice, in case the sf-chain instances within
[[k_term]] and [[isolated]] differ. Next, evaluate the hard
interaction, then compute the convolution with the initial state.
<<Instances: term instance: TBP>>=
procedure :: evaluate_trace => term_instance_evaluate_trace
<<Instances: procedures>>=
subroutine term_instance_evaluate_trace (term)
class(term_instance_t), intent(inout) :: term
class(sf_rescale_t), allocatable :: func
call term%k_term%evaluate_sf_chain (term%fac_scale)
call term%evaluate_scaled_sf_chains ()
call term%isolated%evaluate_sf_chain (term%fac_scale)
call term%isolated%evaluate_trace ()
call term%connected%evaluate_trace ()
end subroutine term_instance_evaluate_trace
@ %def term_instance_evaluate_trace
@ Include rescaled structure functions due to NLO calculation.
We rescale the structure function for the real subtraction [[sf_rescale_collinear]], the collinear
counter terms [[sf_rescale_dglap_t]] and for the case, we have an emitter in the initial state,
rescale the kinematics for it using [[sf_rescale_real_t]].
References: arXiv:0709.2092, (2.35)-(2.42).
Obviously, it is completely irrelevant, which beam is treated.
It becomes problematic when handling [[e, p]]-beams.
<<Instances: term instance: TBP>>=
procedure :: evaluate_scaled_sf_chains => term_instance_evaluate_scaled_sf_chains
<<Instances: procedures>>=
subroutine term_instance_evaluate_scaled_sf_chains (term)
class(term_instance_t), intent(inout) :: term
class(sf_rescale_t), allocatable :: func
integer :: i_sub
if (.not. term%pcm_instance%config%has_pdfs) return
if (term%nlo_type == NLO_REAL) then
if (term%is_subtraction ()) then
allocate (sf_rescale_collinear_t :: func)
select type (pcm => term%pcm_instance)
type is (pcm_instance_nlo_t)
select type (func)
type is (sf_rescale_collinear_t)
call func%set (pcm%real_kinematics%xi_tilde)
call func%set_gluons (.true.)
end select
end select
call term%k_term%sf_chain%evaluate (term%fac_scale, func)
deallocate (func)
else if (term%k_term%emitter >= 0 .and. term%k_term%emitter <= term%k_term%n_in) then
allocate (sf_rescale_real_t :: func)
select type (pcm => term%pcm_instance)
type is (pcm_instance_nlo_t)
select type (func)
type is (sf_rescale_real_t)
call func%set (pcm%real_kinematics%xi_tilde * &
pcm%real_kinematics%xi_max (term%k_term%i_phs), &
pcm%real_kinematics%y (term%k_term%i_phs))
call func%restrict_to_beam (term%k_term%emitter)
end select
end select
call term%k_term%sf_chain%evaluate (term%fac_scale, func)
deallocate (func)
else
call term%k_term%sf_chain%evaluate (term%fac_scale)
end if
else if (term%nlo_type == NLO_DGLAP) then
allocate (sf_rescale_dglap_t :: func)
select type (pcm => term%pcm_instance)
type is (pcm_instance_nlo_t)
select type (func)
type is (sf_rescale_dglap_t)
call func%set (pcm%isr_kinematics%z)
call func%set_gluons (.true.)
end select
end select
call term%k_term%sf_chain%evaluate (term%fac_scale, func)
deallocate (func)
end if
end subroutine term_instance_evaluate_scaled_sf_chains
@ %def term_instance_evaluate_scaled_sf_chains
@ Evaluate the extra data that we need for processing the object as a
physical event.
<<Instances: term instance: TBP>>=
procedure :: evaluate_event_data => term_instance_evaluate_event_data
<<Instances: procedures>>=
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: procedures>>=
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:
<<Instances: term instance: TBP>>=
procedure :: get_fac_scale => term_instance_get_fac_scale
<<Instances: procedures>>=
function term_instance_get_fac_scale (term) result (fac_scale)
class(term_instance_t), intent(in) :: term
real(default) :: fac_scale
fac_scale = term%fac_scale
end function term_instance_get_fac_scale
@ %def term_instance_get_fac_scale
@ We take the strong coupling from the process core. The value is calculated
when a new event is requested, so we should call it only after the event has
been evaluated. If it is not available there (a negative number is returned),
we take the value stored in the term configuration, which should be determined
by the model. If the model does not provide a value, the result is zero.
<<Instances: term instance: TBP>>=
procedure :: get_alpha_s => term_instance_get_alpha_s
<<Instances: procedures>>=
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
@
<<Instances: term instance: TBP>>=
procedure :: reset_phs_identifiers => term_instance_reset_phs_identifiers
<<Instances: procedures>>=
subroutine term_instance_reset_phs_identifiers (term)
class(term_instance_t), intent(inout) :: term
select type (phs => term%k_term%phs)
type is (phs_fks_t)
phs%phs_identifiers%evaluated = .false.
end select
end subroutine term_instance_reset_phs_identifiers
@ %def term_instance_reset_phs_identifiers
@ The second helicity for [[helicities]] comes with a minus sign
because OpenLoops inverts the helicity index of antiparticles.
<<Instances: term instance: TBP>>=
procedure :: get_helicities_for_openloops => term_instance_get_helicities_for_openloops
<<Instances: procedures>>=
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_boost_to_lab => term_instance_get_boost_to_lab
<<Instances: procedures>>=
function term_instance_get_boost_to_lab (term) result (lt)
type(lorentz_transformation_t) :: lt
class(term_instance_t), intent(in) :: term
lt = term%k_term%phs%get_lorentz_transformation ()
end function term_instance_get_boost_to_lab
@ %def term_instance_get_boost_to_lab
@
<<Instances: term instance: TBP>>=
procedure :: get_boost_to_cms => term_instance_get_boost_to_cms
<<Instances: procedures>>=
function term_instance_get_boost_to_cms (term) result (lt)
type(lorentz_transformation_t) :: lt
class(term_instance_t), intent(in) :: term
lt = inverse (term%k_term%phs%get_lorentz_transformation ())
end function term_instance_get_boost_to_cms
@ %def term_instance_get_boost_to_cms
@
<<Instances: term instance: TBP>>=
procedure :: get_i_term_global => term_instance_get_i_term_global
<<Instances: procedures>>=
elemental function term_instance_get_i_term_global (term) result (i_term)
integer :: i_term
class(term_instance_t), intent(in) :: term
i_term = term%config%i_term_global
end function term_instance_get_i_term_global
@ %def term_instance_get_i_term_global
@
<<Instances: term instance: TBP>>=
procedure :: is_subtraction => term_instance_is_subtraction
<<Instances: procedures>>=
elemental function term_instance_is_subtraction (term) result (sub)
logical :: sub
class(term_instance_t), intent(in) :: term
sub = term%config%i_term_global == term%config%i_sub
end function term_instance_is_subtraction
@ %def term_instance_is_subtraction
@ Retrieve [[n_sub]] which was calculated in [[process_term_setup_interaction]].
<<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: procedures>>=
function term_instance_get_n_sub (term) result (n_sub)
integer :: n_sub
class(term_instance_t), intent(in) :: term
n_sub = term%config%n_sub
end function term_instance_get_n_sub
function term_instance_get_n_sub_color (term) result (n_sub_color)
integer :: n_sub_color
class(term_instance_t), intent(in) :: term
n_sub_color = term%config%n_sub_color
end function term_instance_get_n_sub_color
function term_instance_get_n_sub_spin (term) result (n_sub_spin)
integer :: n_sub_spin
class(term_instance_t), intent(in) :: term
n_sub_spin = term%config%n_sub_spin
end function term_instance_get_n_sub_spin
@ %def term_instance_get_n_sub
@ %def term_instance_get_n_sub_color
@ %def term_instance_get_n_sub_spin
@
\subsection{The process instance}
A process instance contains all process data that depend on the
sampling point and thus change often. In essence, it is an event
record at the elementary (parton) level. We do not call it such, to
avoid confusion with the actual event records. If decays are
involved, the latter are compositions of several elementary processes
(i.e., their instances).
We implement the process instance as an extension of the
[[mci_sampler_t]] that we need for computing integrals and generate
events.
The base type contains: the [[integrand]], the [[selected_channel]],
the two-dimensional array [[x]] of parameters, and the one-dimensional
array [[f]] of Jacobians. These subobjects are public and used for
communicating with the multi-channel integrator.
The [[process]] pointer accesses the process of which this record is
an instance. It is required whenever the calculation needs invariant
configuration data, therefore the process should stay in memory for
the whole lifetime of its instances.
The [[evaluation_status]] code is used to check the current status.
In particular, failure at various stages is recorded there.
The [[count]] object records process evaluations, broken down
according to status.
The [[sqme]] value is the single real number that results from
evaluating and tracing the kinematics and matrix elements. This
is the number that is handed over to an integration routine.
The [[weight]] value is the event weight. It is defined when an event
has been generated from the process instance, either weighted or
unweighted. The value is the [[sqme]] value times Jacobian weights
from the integration, or unity, respectively.
The [[i_mci]] index chooses a subset of components that are associated with
a common parameter set and integrator, i.e., that are added coherently.
The [[sf_chain]] subobject is a realization of the beam and
structure-function configuration in the [[process]] object. It is not
used for calculation directly but serves as the template for the
sf-chain instances that are contained in the [[component]] objects.
The [[component]] subobjects determine the state of each component.
The [[term]] subobjects are workspace for evaluating kinematics,
matrix elements, cuts etc.
The [[mci_work]] subobject contains the array of real input parameters (random
numbers) that generates the kinematical point. It also contains the workspace
for the MC integrators. The active entry of the [[mci_work]] array is
selected by the [[i_mci]] index above.
The [[hook]] pointer accesses a list of after evaluate objects which are
evalutated after the matrix element.
<<Instances: public>>=
public :: process_instance_t
<<Instances: types>>=
type, extends (mci_sampler_t) :: process_instance_t
type(process_t), pointer :: process => null ()
integer :: evaluation_status = STAT_UNDEFINED
real(default) :: sqme = 0
real(default) :: weight = 0
real(default) :: excess = 0
integer :: n_dropped = 0
integer :: i_mci = 0
integer :: selected_channel = 0
type(sf_chain_t) :: sf_chain
type(term_instance_t), dimension(:), allocatable :: term
type(mci_work_t), dimension(:), allocatable :: mci_work
class(pcm_instance_t), allocatable :: pcm
class(process_instance_hook_t), pointer :: hook => null ()
contains
<<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 a [[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)
import :: process_instance_hook_t, var_list_t, process_instance_t
class(process_instance_hook_t), intent(inout), target :: hook
type(var_list_t), intent(in) :: var_list
class(process_instance_t), intent(in), target :: instance
end subroutine process_instance_hook_init
subroutine process_instance_hook_final (hook)
import :: process_instance_hook_t
class(process_instance_hook_t), intent(inout) :: hook
end subroutine process_instance_hook_final
subroutine process_instance_hook_evaluate (hook, instance)
import :: process_instance_hook_t, process_instance_t
class(process_instance_hook_t), intent(inout) :: hook
class(process_instance_t), intent(in), target :: instance
end subroutine process_instance_hook_evaluate
end interface
@ %def process_instance_hook_final, process_instance_hook_evaluate
@ The output routine contains a header with the most relevant
information about the process, copied from
[[process_metadata_write]]. We mark the active components by an asterisk.
The next section is the MC parameter input. The following sections
are written only if the evaluation status is beyond setting the
parameters, or if the [[verbose]] option is set.
<<Instances: process instance: TBP>>=
procedure :: write_header => process_instance_write_header
procedure :: write => process_instance_write
<<Instances: procedures>>=
subroutine process_instance_write_header (object, unit, testflag)
class(process_instance_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
integer :: u
u = given_output_unit (unit)
call write_separator (u, 2)
if (associated (object%process)) then
call object%process%write_meta (u, testflag)
else
write (u, "(1x,A)") "Process instance [undefined process]"
return
end if
write (u, "(3x,A)", advance = "no") "status = "
select case (object%evaluation_status)
case (STAT_INITIAL); write (u, "(A)") "initialized"
case (STAT_ACTIVATED); write (u, "(A)") "activated"
case (STAT_BEAM_MOMENTA); write (u, "(A)") "beam momenta set"
case (STAT_FAILED_KINEMATICS); write (u, "(A)") "failed kinematics"
case (STAT_SEED_KINEMATICS); write (u, "(A)") "seed kinematics"
case (STAT_HARD_KINEMATICS); write (u, "(A)") "hard kinematics"
case (STAT_EFF_KINEMATICS); write (u, "(A)") "effective kinematics"
case (STAT_FAILED_CUTS); write (u, "(A)") "failed cuts"
case (STAT_PASSED_CUTS); write (u, "(A)") "passed cuts"
case (STAT_EVALUATED_TRACE); write (u, "(A)") "evaluated trace"
call write_separator (u)
write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme
case (STAT_EVENT_COMPLETE); write (u, "(A)") "event complete"
call write_separator (u)
write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme
write (u, "(3x,A,ES19.12)") "weight = ", object%weight
if (.not. vanishes (object%excess)) &
write (u, "(3x,A,ES19.12)") "excess = ", object%excess
case default; write (u, "(A)") "undefined"
end select
if (object%i_mci /= 0) then
call write_separator (u)
call object%mci_work(object%i_mci)%write (u, testflag)
end if
call write_separator (u, 2)
end subroutine process_instance_write_header
subroutine process_instance_write (object, unit, testflag)
class(process_instance_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
integer :: u, i
u = given_output_unit (unit)
call object%write_header (u)
if (object%evaluation_status >= STAT_BEAM_MOMENTA) then
call object%sf_chain%write (u)
call write_separator (u, 2)
if (object%evaluation_status >= STAT_SEED_KINEMATICS) then
if (object%evaluation_status >= STAT_HARD_KINEMATICS) then
call write_separator (u, 2)
write (u, "(1x,A)") "Active terms:"
if (any (object%term%active)) then
do i = 1, size (object%term)
if (object%term(i)%active) then
call write_separator (u)
call object%term(i)%write (u, &
show_eff_state = &
object%evaluation_status >= STAT_EFF_KINEMATICS, &
testflag = testflag)
end if
end do
end if
end if
call write_separator (u, 2)
end if
end if
end subroutine process_instance_write
@ %def process_instance_write_header
@ %def process_instance_write
@ Initialization connects the instance with a process. All initial
information is transferred from the process object. The process
object contains templates for the interaction subobjects (beam and
term), but no evaluators. The initialization routine
creates evaluators for the matrix element trace, other evaluators
are left untouched.
Before we start generating, we double-check if the process library
has been updated after the process was initializated
([[check_library_sanity]]). This may happen if between integration
and event generation the library has been recompiled, so all links
become broken.
The [[instance]] object must have the [[target]] attribute (also in
any caller) since the initialization routine assigns various pointers
to subobject of [[instance]].
<<Instances: process instance: TBP>>=
procedure :: init => process_instance_init
<<Instances: procedures>>=
subroutine process_instance_init (instance, process)
class(process_instance_t), intent(out), target :: instance
type(process_t), intent(inout), target :: process
integer :: i
class(pcm_t), pointer :: pcm
type(process_term_t) :: term
type(var_list_t), pointer :: var_list
integer :: i_born, i_real, i_real_fin
if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_instance_init")
instance%process => process
call instance%process%check_library_sanity ()
call instance%setup_sf_chain (process%get_beam_config_ptr ())
allocate (instance%mci_work (process%get_n_mci ()))
do i = 1, size (instance%mci_work)
call instance%process%init_mci_work (instance%mci_work(i), i)
end do
call instance%process%reset_selected_cores ()
pcm => instance%process%get_pcm_ptr ()
call pcm%allocate_instance (instance%pcm)
call instance%pcm%link_config (pcm)
select type (pcm)
type is (pcm_nlo_t)
!!! The process is kept when the integration is finalized, but not the
!!! process_instance. Thus, we check whether pcm has been initialized
!!! but set up the pcm_instance each time.
i_real_fin = process%get_associated_real_fin (1)
if (.not. pcm%initialized) then
! i_born = pcm%get_i_core_nlo_type (BORN)
i_born = pcm%get_i_core (pcm%i_born)
! i_real = pcm%get_i_core_nlo_type (NLO_REAL, include_sub = .false.)
! i_real = pcm%get_i_core_nlo_type (NLO_REAL)
i_real = pcm%get_i_core (pcm%i_real)
term = process%get_term_ptr (process%get_i_term (i_real))
call pcm%init_qn (process%get_model_ptr ())
if (i_real_fin > 0) call pcm%allocate_ps_matching ()
var_list => process%get_var_list_ptr ()
if (var_list%get_sval (var_str ("$dalitz_plot")) /= var_str ('')) &
call pcm%activate_dalitz_plot (var_list%get_sval (var_str ("$dalitz_plot")))
end if
pcm%initialized = .true.
select type (pcm_instance => instance%pcm)
type is (pcm_instance_nlo_t)
call pcm_instance%init_config (process%component_can_be_integrated (), &
process%get_nlo_type_component (), process%get_sqrts (), i_real_fin, &
process%get_model_ptr ())
end select
end select
allocate (instance%term (process%get_n_terms ()))
do i = 1, process%get_n_terms ()
call instance%term(i)%init_from_process (process, i, instance%pcm, &
instance%sf_chain)
end do
call instance%set_i_mci_to_real_component ()
call instance%find_same_kinematics ()
instance%evaluation_status = STAT_INITIAL
end subroutine process_instance_init
@ %def process_instance_init
@
@ Finalize all subobjects that may contain allocated pointers.
<<Instances: process instance: TBP>>=
procedure :: final => process_instance_final
<<Instances: procedures>>=
subroutine process_instance_final (instance)
class(process_instance_t), intent(inout) :: instance
class(process_instance_hook_t), pointer :: current
integer :: i
instance%process => null ()
if (allocated (instance%mci_work)) then
do i = 1, size (instance%mci_work)
call instance%mci_work(i)%final ()
end do
deallocate (instance%mci_work)
end if
call instance%sf_chain%final ()
if (allocated (instance%term)) then
do i = 1, size (instance%term)
call instance%term(i)%final ()
end do
deallocate (instance%term)
end if
call instance%pcm%final ()
instance%evaluation_status = STAT_UNDEFINED
do while (associated (instance%hook))
current => instance%hook
call current%final ()
instance%hook => current%next
deallocate (current)
end do
instance%hook => null ()
end subroutine process_instance_final
@ %def process_instance_final
@ Revert the process instance to initial state. We do not deallocate
anything, just reset the state index and deactivate all components and
terms.
We do not reset the choice of the MCI set [[i_mci]] unless this is
required explicitly.
<<Instances: process instance: TBP>>=
procedure :: reset => process_instance_reset
<<Instances: procedures>>=
subroutine process_instance_reset (instance, reset_mci)
class(process_instance_t), intent(inout) :: instance
logical, intent(in), optional :: reset_mci
integer :: i
call instance%process%reset_selected_cores ()
do i = 1, size (instance%term)
call instance%term(i)%reset ()
end do
instance%term%checked = .false.
instance%term%passed = .false.
instance%term%k_term%new_seed = .true.
if (present (reset_mci)) then
if (reset_mci) instance%i_mci = 0
end if
instance%selected_channel = 0
instance%evaluation_status = STAT_INITIAL
end subroutine process_instance_reset
@ %def process_instance_reset
@
\subsubsection{Integration and event generation}
The sampler test should just evaluate the squared matrix element [[n_calls]]
times, discarding the results, and return. This can be done before
integration, e.g., for timing estimates.
<<Instances: process instance: TBP>>=
procedure :: sampler_test => process_instance_sampler_test
<<Instances: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_instance_find_same_kinematics (instance)
class(process_instance_t), intent(inout) :: instance
integer :: i_term1, i_term2, k, n_same
do i_term1 = 1, size (instance%term)
if (.not. allocated (instance%term(i_term1)%same_kinematics)) then
n_same = 1 !!! Index group includes the index of its term_instance
do i_term2 = 1, size (instance%term)
if (i_term1 == i_term2) cycle
if (compare_md5s (i_term1, i_term2)) n_same = n_same + 1
end do
allocate (instance%term(i_term1)%same_kinematics (n_same))
associate (same_kinematics1 => instance%term(i_term1)%same_kinematics)
same_kinematics1 = 0
k = 1
do i_term2 = 1, size (instance%term)
if (compare_md5s (i_term1, i_term2)) then
same_kinematics1(k) = i_term2
k = k + 1
end if
end do
do k = 1, size (same_kinematics1)
if (same_kinematics1(k) == i_term1) cycle
i_term2 = same_kinematics1(k)
allocate (instance%term(i_term2)%same_kinematics (n_same))
instance%term(i_term2)%same_kinematics = same_kinematics1
end do
end associate
end if
end do
contains
function compare_md5s (i, j) result (same)
logical :: same
integer, intent(in) :: i, j
character(32) :: md5sum_1, md5sum_2
integer :: mode_1, mode_2
mode_1 = 0; mode_2 = 0
select type (phs => instance%term(i)%k_term%phs%config)
type is (phs_fks_config_t)
md5sum_1 = phs%md5sum_born_config
mode_1 = phs%mode
class default
md5sum_1 = phs%md5sum_phs_config
end select
select type (phs => instance%term(j)%k_term%phs%config)
type is (phs_fks_config_t)
md5sum_2 = phs%md5sum_born_config
mode_2 = phs%mode
class default
md5sum_2 = phs%md5sum_phs_config
end select
same = (md5sum_1 == md5sum_2) .and. (mode_1 == mode_2)
end function compare_md5s
end subroutine process_instance_find_same_kinematics
@ %def process_instance_find_same_kinematics
@
<<Instances: process instance: TBP>>=
procedure :: transfer_same_kinematics => process_instance_transfer_same_kinematics
<<Instances: procedures>>=
subroutine process_instance_transfer_same_kinematics (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
integer :: i, i_term_same
associate (same_kinematics => instance%term(i_term)%same_kinematics)
do i = 1, size (same_kinematics)
i_term_same = same_kinematics(i)
if (i_term_same /= i_term) then
instance%term(i_term_same)%p_seed = instance%term(i_term)%p_seed
associate (phs => instance%term(i_term_same)%k_term%phs)
call phs%set_lorentz_transformation &
(instance%term(i_term)%k_term%phs%get_lorentz_transformation ())
select type (phs)
type is (phs_fks_t)
call phs%set_momenta (instance%term(i_term_same)%p_seed)
call phs%set_reference_frames (.false.)
end select
end associate
end if
instance%term(i_term_same)%k_term%new_seed = .false.
end do
end associate
end subroutine process_instance_transfer_same_kinematics
@ %def process_instance_transfer_same_kinematics
@
<<Instances: process instance: TBP>>=
procedure :: redo_sf_chains => process_instance_redo_sf_chains
<<Instances: procedures>>=
subroutine process_instance_redo_sf_chains (instance, i_term, phs_channel)
class(process_instance_t), intent(inout) :: instance
integer, intent(in), dimension(:) :: i_term
integer, intent(in) :: phs_channel
integer :: i
do i = 1, size (i_term)
call instance%term(i_term(i))%redo_sf_chain &
(instance%mci_work(instance%i_mci), phs_channel)
end do
end subroutine process_instance_redo_sf_chains
@ %def process_instance_redo_sf_chains
@ Integrate the process, using a previously initialized process
instance. We select one of the available MCI integrators by its index
[[i_mci]] and thus integrate over (structure functions and) phase
space for the associated (group of) process component(s).
<<Instances: process instance: TBP>>=
procedure :: integrate => process_instance_integrate
<<Instances: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_instance_setup_event_data (instance, model, i_core)
class(process_instance_t), intent(inout), target :: instance
class(model_data_t), intent(in), optional, target :: model
integer, intent(in), optional :: i_core
class(model_data_t), pointer :: current_model
integer :: i
class(prc_core_t), pointer :: core => null ()
if (present (model)) then
current_model => model
else
current_model => instance%process%get_model_ptr ()
end if
do i = 1, size (instance%term)
associate (term => instance%term(i))
if (associated (term%config)) then
core => instance%process%get_core_term (i)
call term%setup_event_data (core, current_model)
end if
end associate
end do
core => null ()
end subroutine process_instance_setup_event_data
@ %def process_instance_setup_event_data
@ Choose a MC parameter set and the corresponding integrator.
The choice persists beyond calls of the [[reset]] method above. This method
is automatically called here.
<<Instances: process instance: TBP>>=
procedure :: choose_mci => process_instance_choose_mci
<<Instances: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_instance_recover_beam_momenta (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
if (.not. instance%process%lab_is_cm_frame ()) then
if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
call instance%term(i_term)%return_beam_momenta ()
end if
end if
end subroutine process_instance_recover_beam_momenta
@ %def process_instance_recover_beam_momenta
@ Explicitly choose MC integration channel. We assume here that the channel
count is identical for all active components.
<<Instances: process instance: TBP>>=
procedure :: select_channel => process_instance_select_channel
<<Instances: procedures>>=
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: procedures>>=
subroutine process_instance_compute_seed_kinematics (instance, skip_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in), optional :: skip_term
integer :: channel, skip_component, i, j
logical :: success
integer, dimension(:), allocatable :: i_term
channel = instance%selected_channel
if (channel == 0) then
call msg_bug ("Compute seed kinematics: undefined integration channel")
end if
if (present (skip_term)) then
skip_component = instance%term(skip_term)%config%i_component
else
skip_component = 0
end if
if (instance%evaluation_status >= STAT_ACTIVATED) then
success = .true.
do i = 1, instance%process%get_n_components ()
if (i == skip_component) cycle
if (instance%process%component_is_selected (i)) then
allocate (i_term (size (instance%process%get_component_i_terms (i))))
i_term = instance%process%get_component_i_terms (i)
do j = 1, size (i_term)
if (instance%term(i_term(j))%k_term%new_seed) then
call instance%term(i_term(j))%compute_seed_kinematics &
(instance%mci_work(instance%i_mci), channel, success)
call instance%transfer_same_kinematics (i_term(j))
end if
if (.not. success) exit
call instance%term(i_term(j))%evaluate_projections ()
call instance%term(i_term(j))%evaluate_radiation_kinematics &
(instance%mci_work(instance%i_mci)%get_x_process ())
call instance%term(i_term(j))%generate_fsr_in ()
call instance%term(i_term(j))%compute_xi_ref_momenta ()
end do
end if
if (allocated (i_term)) deallocate (i_term)
end do
if (success) then
instance%evaluation_status = STAT_SEED_KINEMATICS
else
instance%evaluation_status = STAT_FAILED_KINEMATICS
end if
end if
associate (mci_work => instance%mci_work(instance%i_mci))
select type (pcm => instance%pcm)
class is (pcm_instance_nlo_t)
call pcm%set_x_rad (mci_work%get_x_process ())
end select
end associate
end subroutine process_instance_compute_seed_kinematics
@ %def process_instance_compute_seed_kinematics
@
<<Instances: process instance: TBP>>=
procedure :: get_x_process => process_instance_get_x_process
<<Instances: procedures>>=
pure function process_instance_get_x_process (instance) result (x)
real(default), dimension(:), allocatable :: x
class(process_instance_t), intent(in) :: instance
allocate (x(size (instance%mci_work(instance%i_mci)%get_x_process ())))
x = instance%mci_work(instance%i_mci)%get_x_process ()
end function process_instance_get_x_process
@ %def process_instance_get_x_process
@
<<Instances: process instance: TBP>>=
procedure :: get_active_component_type => process_instance_get_active_component_type
<<Instances: procedures>>=
pure function process_instance_get_active_component_type (instance) &
result (nlo_type)
integer :: nlo_type
class(process_instance_t), intent(in) :: instance
nlo_type = instance%process%get_component_nlo_type (instance%i_mci)
end function process_instance_get_active_component_type
@ %def process_instance_get_active_component_type
@ Inverse: recover missing parts of the kinematics from the momentum
configuration, which we know for a single term and component. Given
a channel, reconstruct the MC parameter set.
<<Instances: process instance: TBP>>=
procedure :: recover_mcpar => process_instance_recover_mcpar
<<Instances: procedures>>=
subroutine process_instance_recover_mcpar (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
integer :: channel
if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
channel = instance%selected_channel
if (channel == 0) then
call msg_bug ("Recover MC parameters: undefined integration channel")
end if
call instance%term(i_term)%recover_mcpar &
(instance%mci_work(instance%i_mci), channel)
end if
end subroutine process_instance_recover_mcpar
@ %def process_instance_recover_mcpar
@ This is part of [[recover_mcpar]], extracted for the case when there is
no phase space and parameters to recover, but we still need the structure
function kinematics for evaluation.
<<Instances: process instance: TBP>>=
procedure :: recover_sfchain => process_instance_recover_sfchain
<<Instances: procedures>>=
subroutine process_instance_recover_sfchain (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
integer :: channel
if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
channel = instance%selected_channel
if (channel == 0) then
call msg_bug ("Recover sfchain: undefined integration channel")
end if
call instance%term(i_term)%recover_sfchain (channel)
end if
end subroutine process_instance_recover_sfchain
@ %def process_instance_recover_sfchain
@ Second step of process evaluation: compute all momenta, for all active
components, from the seed kinematics.
<<Instances: process instance: TBP>>=
procedure :: compute_hard_kinematics => &
process_instance_compute_hard_kinematics
<<Instances: procedures>>=
subroutine process_instance_compute_hard_kinematics (instance, skip_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in), optional :: skip_term
integer :: i
logical :: success
success = .true.
if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then
do i = 1, size (instance%term)
if (instance%term(i)%active) then
call instance%term(i)%compute_hard_kinematics (skip_term, success)
if (.not. success) exit
!!! Ren scale is zero when this is commented out! Understand!
if (instance%term(i)%nlo_type == NLO_REAL) &
call instance%term(i)%redo_sf_chain (instance%mci_work(instance%i_mci), &
instance%selected_channel)
end if
end do
if (success) then
instance%evaluation_status = STAT_HARD_KINEMATICS
else
instance%evaluation_status = STAT_FAILED_KINEMATICS
end if
end if
end subroutine process_instance_compute_hard_kinematics
@ %def process_instance_setup_compute_hard_kinematics
@ Inverse: recover seed kinematics. We know the beam momentum
configuration and the outgoing momenta of the effective interaction,
for one specific term.
<<Instances: process instance: TBP>>=
procedure :: recover_seed_kinematics => &
process_instance_recover_seed_kinematics
<<Instances: procedures>>=
subroutine process_instance_recover_seed_kinematics (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
if (instance%evaluation_status >= STAT_EFF_KINEMATICS) &
call instance%term(i_term)%recover_seed_kinematics ()
end subroutine process_instance_recover_seed_kinematics
@ %def process_instance_recover_seed_kinematics
@ Third step of process evaluation: compute the effective momentum
configurations, for all active terms, from the hard kinematics.
<<Instances: process instance: TBP>>=
procedure :: compute_eff_kinematics => &
process_instance_compute_eff_kinematics
<<Instances: procedures>>=
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: procedures>>=
subroutine process_instance_recover_hard_kinematics (instance, i_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term
integer :: i
if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
call instance%term(i_term)%recover_hard_kinematics ()
do i = 1, size (instance%term)
if (i /= i_term) then
if (instance%term(i)%active) then
call instance%term(i)%compute_eff_kinematics ()
end if
end if
end do
instance%evaluation_status = STAT_EFF_KINEMATICS
end if
end subroutine process_instance_recover_hard_kinematics
@ %def recover_hard_kinematics
@ Fourth step of process evaluation: check cuts for all terms. Where
sucessful, compute any scales and weights. Otherwise, deactive the term.
If any of the terms has passed, set the state to [[STAT_PASSED_CUTS]].
The argument [[scale_forced]], if present, will override the scale calculation
in the term expressions.
<<Instances: process instance: TBP>>=
procedure :: evaluate_expressions => &
process_instance_evaluate_expressions
<<Instances: procedures>>=
subroutine process_instance_evaluate_expressions (instance, scale_forced)
class(process_instance_t), intent(inout) :: instance
real(default), intent(in), allocatable, optional :: scale_forced
integer :: i
logical :: passed_real
if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
do i = 1, size (instance%term)
if (instance%term(i)%active) then
call instance%term(i)%evaluate_expressions (scale_forced)
end if
end do
call evaluate_real_scales_and_cuts ()
if (.not. passed_real) then
instance%evaluation_status = STAT_FAILED_CUTS
else
if (any (instance%term%passed)) then
instance%evaluation_status = STAT_PASSED_CUTS
else
instance%evaluation_status = STAT_FAILED_CUTS
end if
end if
end if
contains
subroutine evaluate_real_scales_and_cuts ()
integer :: i
passed_real = .true.
select type (config => instance%pcm%config)
type is (pcm_nlo_t)
do i = 1, size (instance%term)
if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_REAL) then
if (config%settings%cut_all_sqmes) &
passed_real = passed_real .and. instance%term(i)%passed
if (config%settings%use_born_scale) &
call replace_scales (instance%term(i))
end if
end do
end select
end subroutine evaluate_real_scales_and_cuts
subroutine replace_scales (this_term)
type(term_instance_t), intent(inout) :: this_term
integer :: i_sub
i_sub = this_term%config%i_sub
if (this_term%config%i_term_global /= i_sub .and. i_sub > 0) then
this_term%ren_scale = instance%term(i_sub)%ren_scale
this_term%fac_scale = instance%term(i_sub)%fac_scale
end if
end subroutine replace_scales
end subroutine process_instance_evaluate_expressions
@ %def process_instance_evaluate_expressions
@ Fifth step of process evaluation: fill the parameters for the non-selected
,channels, that have not been used for seeding. We should do this after
evaluating cuts, since we may save some expensive calculations if the phase
space point fails the cuts.
If [[skip_term]] is set, we skip the component that accesses this
term. We can assume that the associated data have already been
recovered, and we are just computing the rest.
<<Instances: process instance: TBP>>=
procedure :: compute_other_channels => &
process_instance_compute_other_channels
<<Instances: procedures>>=
subroutine process_instance_compute_other_channels (instance, skip_term)
class(process_instance_t), intent(inout) :: instance
integer, intent(in), optional :: skip_term
integer :: channel, skip_component, i, j
integer, dimension(:), allocatable :: i_term
channel = instance%selected_channel
if (channel == 0) then
call msg_bug ("Compute other channels: undefined integration channel")
end if
if (present (skip_term)) then
skip_component = instance%term(skip_term)%config%i_component
else
skip_component = 0
end if
if (instance%evaluation_status >= STAT_PASSED_CUTS) then
do i = 1, instance%process%get_n_components ()
if (i == skip_component) cycle
if (instance%process%component_is_selected (i)) then
allocate (i_term (size (instance%process%get_component_i_terms (i))))
i_term = instance%process%get_component_i_terms (i)
do j = 1, size (i_term)
call instance%term(i_term(j))%compute_other_channels &
(instance%mci_work(instance%i_mci), channel)
end do
end if
if (allocated (i_term)) deallocate (i_term)
end do
end if
end subroutine process_instance_compute_other_channels
@ %def process_instance_compute_other_channels
@ If not done otherwise, we an flag the kinematics as new for the core state,
such that the routine below will actually compute the matrix element and not
just look it up.
<<Instances: process instance: TBP>>=
procedure :: reset_core_kinematics => process_instance_reset_core_kinematics
<<Instances: procedures>>=
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: procedures>>=
subroutine process_instance_evaluate_trace (instance)
class(process_instance_t), intent(inout) :: instance
class(prc_core_t), pointer :: core => null ()
integer :: i, i_real_fin, i_core
real(default) :: alpha_s, alpha_qed
class(prc_core_t), pointer :: core_sub => null ()
class(model_data_t), pointer :: model => null ()
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_evaluate_trace")
instance%sqme = zero
call instance%reset_matrix_elements ()
if (instance%evaluation_status >= STAT_PASSED_CUTS) then
do i = 1, size (instance%term)
associate (term => instance%term(i))
if (term%active .and. term%passed) then
core => instance%process%get_core_term (i)
select type (pcm => instance%process%get_pcm_ptr ())
class is (pcm_nlo_t)
i_core = pcm%get_i_core (pcm%i_sub)
core_sub => instance%process%get_core_ptr (i_core)
end select
! if (instance%pcm%config%is_nlo ()) &
! core_sub => instance%process%get_subtraction_core ()
call term%evaluate_interaction (core)
call term%evaluate_trace ()
i_real_fin = instance%process%get_associated_real_fin (1)
if (instance%process%uses_real_partition ()) &
call term%apply_real_partition (instance%process)
if (term%config%i_component /= i_real_fin) then
if ((term%nlo_type == NLO_REAL .and. term%k_term%emitter < 0) &
.or. term%nlo_type == NLO_MISMATCH &
.or. term%nlo_type == NLO_DGLAP) &
call term%set_born_sqmes (core)
if (term%nlo_type > BORN) then
if (.not. (term%nlo_type == NLO_REAL .and. term%k_term%emitter >= 0)) then
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
if (char (config%settings%nlo_correction_type) == "QCD" .or. &
char (config%settings%nlo_correction_type) == "Full") &
call term%evaluate_color_correlations (core_sub)
if (char (config%settings%nlo_correction_type) == "QED" .or. &
char (config%settings%nlo_correction_type) == "Full") &
call term%evaluate_charge_correlations (core_sub)
end select
end if
if (term%is_subtraction ()) then
call term%evaluate_spin_correlations (core_sub)
end if
if ((term%is_subtraction () .or. term%nlo_type == NLO_DGLAP) &
.and. term%pcm_instance%config%has_pdfs) &
call term%compute_sqme_coll_isr ()
end if
alpha_s = core%get_alpha_s (term%core_state)
!!!! TODO (wk 2019-02-07): this method for resetting alpha_em is not used (yet),
!!!! and it slows down the program significantly by using string handling.
!!! Should be removed or replaced by an efficient method.
alpha_qed = 0
!!! if (associated (instance%process%get_model_ptr ())) then
!!! model => instance%process%get_model_ptr ()
!!! if (associated (model%get_par_data_ptr (var_str ('alpha_em_i')))) &
!!! alpha_qed = one / model%get_real (var_str ('alpha_em_i'))
!!! model => null ()
!!! end if
select case (term%nlo_type)
case (NLO_REAL)
call term%apply_fks (alpha_s, alpha_qed)
case (NLO_VIRTUAL)
call term%evaluate_sqme_virt (alpha_s, alpha_qed)
case (NLO_MISMATCH)
call term%evaluate_sqme_mismatch (alpha_s)
case (NLO_DGLAP)
call term%evaluate_sqme_dglap (alpha_s)
end select
end if
end if
core_sub => null ()
instance%sqme = instance%sqme + real (sum (&
term%connected%trace%get_matrix_element () * &
term%weight))
end associate
end do
core => null ()
if (instance%pcm%is_valid ()) then
instance%evaluation_status = STAT_EVALUATED_TRACE
else
instance%evaluation_status = STAT_FAILED_KINEMATICS
end if
else
!!! Failed kinematics or failed cuts: set sqme to zero
instance%sqme = zero
end if
end subroutine process_instance_evaluate_trace
@ %def process_instance_evaluate_trace
<<Instances: term instance: TBP>>=
procedure :: set_born_sqmes => term_instance_set_born_sqmes
<<Instances: procedures>>=
subroutine term_instance_set_born_sqmes (term, core)
class(term_instance_t), intent(inout) :: term
class(prc_core_t), intent(in) :: core
integer :: i_flv, ii_flv
real(default) :: sqme
select type (pcm_instance => term%pcm_instance)
type is (pcm_instance_nlo_t)
do i_flv = 1, term%connected_qn_index%get_n_flv ()
ii_flv = term%connected_qn_index%get_index (i_flv, i_sub = 0)
sqme = real (term%connected%trace%get_matrix_element (ii_flv))
select case (term%nlo_type)
case (NLO_REAL)
pcm_instance%real_sub%sqme_born(i_flv) = sqme
case (NLO_MISMATCH)
pcm_instance%soft_mismatch%sqme_born(i_flv) = sqme
case (NLO_DGLAP)
pcm_instance%dglap_remnant%sqme_born(i_flv) = sqme
end select
end do
end select
end subroutine term_instance_set_born_sqmes
@
<<Instances: process instance: TBP>>=
procedure :: apply_real_partition => process_instance_apply_real_partition
<<Instances: procedures>>=
subroutine process_instance_apply_real_partition (instance)
class(process_instance_t), intent(inout) :: instance
integer :: i_component, i_term
integer, dimension(:), allocatable :: i_terms
associate (process => instance%process)
i_component = process%get_first_real_component ()
if (process%component_is_selected (i_component) .and. &
process%get_component_nlo_type (i_component) == NLO_REAL) then
allocate (i_terms (size (process%get_component_i_terms (i_component))))
i_terms = process%get_component_i_terms (i_component)
do i_term = 1, size (i_terms)
call instance%term(i_terms(i_term))%apply_real_partition (process)
end do
end if
if (allocated (i_terms)) deallocate (i_terms)
end associate
end subroutine process_instance_apply_real_partition
@ %def process_instance_apply_real_partition
@
<<Instances: process instance: TBP>>=
procedure :: set_i_mci_to_real_component => process_instance_set_i_mci_to_real_component
<<Instances: procedures>>=
subroutine process_instance_set_i_mci_to_real_component (instance)
class(process_instance_t), intent(inout) :: instance
integer :: i_mci, i_component
type(process_component_t), pointer :: component => null ()
select type (pcm_instance => instance%pcm)
type is (pcm_instance_nlo_t)
if (allocated (pcm_instance%i_mci_to_real_component)) then
call msg_warning ("i_mci_to_real_component already allocated - replace it")
deallocate (pcm_instance%i_mci_to_real_component)
end if
allocate (pcm_instance%i_mci_to_real_component (size (instance%mci_work)))
do i_mci = 1, size (instance%mci_work)
do i_component = 1, instance%process%get_n_components ()
component => instance%process%get_component_ptr (i_component)
if (component%i_mci /= i_mci) cycle
select case (component%component_type)
case (COMP_MASTER, COMP_REAL)
pcm_instance%i_mci_to_real_component (i_mci) = &
component%config%get_associated_real ()
case (COMP_REAL_FIN)
pcm_instance%i_mci_to_real_component (i_mci) = &
component%config%get_associated_real_fin ()
case (COMP_REAL_SING)
pcm_instance%i_mci_to_real_component (i_mci) = &
component%config%get_associated_real_sing ()
end select
end do
end do
component => null ()
end select
end subroutine process_instance_set_i_mci_to_real_component
@ %def process_instance_set_i_mci_to_real_component
@ Final step of process evaluation: evaluate the matrix elements, and compute
the trace (summed over quantum numbers) for all terms. Finally, sum up the
terms, iterating over all active process components.
If [[weight]] is provided, we already know the kinematical event
weight (the MCI weight which depends on the kinematics sampling
algorithm, but not on the matrix element), so we do not need to take
it from the MCI record.
<<Instances: process instance: TBP>>=
procedure :: evaluate_event_data => process_instance_evaluate_event_data
<<Instances: procedures>>=
subroutine process_instance_evaluate_event_data (instance, weight)
class(process_instance_t), intent(inout) :: instance
real(default), intent(in), optional :: weight
integer :: i
if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then
do i = 1, size (instance%term)
associate (term => instance%term(i))
if (term%active .and. term%passed) then
call term%evaluate_event_data ()
end if
end associate
end do
if (present (weight)) then
instance%weight = weight
else
instance%weight = &
instance%mci_work(instance%i_mci)%mci%get_event_weight ()
instance%excess = &
instance%mci_work(instance%i_mci)%mci%get_event_excess ()
end if
instance%n_dropped = &
instance%mci_work(instance%i_mci)%mci%get_n_event_dropped ()
instance%evaluation_status = STAT_EVENT_COMPLETE
else
!!! failed kinematics etc.: set weight to zero
instance%weight = zero
!!! Maybe we want to keep the event nevertheless
if (instance%keep_failed_events ()) then
!!! Force factorization scale, otherwise writing to event output fails
do i = 1, size (instance%term)
instance%term(i)%fac_scale = zero
end do
instance%evaluation_status = STAT_EVENT_COMPLETE
end if
end if
end subroutine process_instance_evaluate_event_data
@ %def process_instance_evaluate_event_data
@ Computes the real-emission matrix element for externally supplied momenta. Also,
e.g. for Powheg, there is the possibility to supply an external $\alpha_s$
<<Instances: process instance: TBP>>=
procedure :: compute_sqme_rad => process_instance_compute_sqme_rad
<<Instances: procedures>>=
subroutine process_instance_compute_sqme_rad &
(instance, i_term, i_phs, is_subtraction, alpha_s_external)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_term, i_phs
logical, intent(in) :: is_subtraction
real(default), intent(in), optional :: alpha_s_external
class(prc_core_t), pointer :: core
integer :: i_real_fin
if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_compute_sqme_rad")
select type (pcm => instance%pcm)
type is (pcm_instance_nlo_t)
associate (term => instance%term(i_term))
core => instance%process%get_core_term (i_term)
if (is_subtraction) then
call pcm%set_subtraction_event ()
else
call pcm%set_radiation_event ()
end if
call term%int_hard%set_momenta (pcm%get_momenta &
(i_phs = i_phs, born_phsp = is_subtraction))
if (allocated (term%core_state)) &
call term%core_state%reset_new_kinematics ()
if (present (alpha_s_external)) &
call term%set_alpha_qcd_forced (alpha_s_external)
call term%compute_eff_kinematics ()
call term%evaluate_expressions ()
call term%evaluate_interaction (core)
call term%evaluate_trace ()
pcm%real_sub%sqme_born (1) = &
real (term%connected%trace%get_matrix_element (1))
if (term%is_subtraction ()) then
select type (config => term%pcm_instance%config)
type is (pcm_nlo_t)
if (char (config%settings%nlo_correction_type) == "QCD" .or. &
char (config%settings%nlo_correction_type) == "Full") &
call term%evaluate_color_correlations (core)
if (char (config%settings%nlo_correction_type) == "QED" .or. &
char (config%settings%nlo_correction_type) == "Full") &
call term%evaluate_charge_correlations (core)
end select
call term%evaluate_spin_correlations (core)
if (term%pcm_instance%config%has_pdfs) &
call term%compute_sqme_coll_isr ()
else if (term%nlo_type == NLO_DGLAP) then
call term%compute_sqme_coll_isr ()
end if
i_real_fin = instance%process%get_associated_real_fin (1)
if (term%config%i_component /= i_real_fin) &
call term%apply_fks (core%get_alpha_s (term%core_state), 0._default)
if (instance%process%uses_real_partition ()) &
call instance%apply_real_partition ()
end associate
end select
core => null ()
end subroutine process_instance_compute_sqme_rad
@ %def process_instance_compute_sqme_rad
@ For unweighted event generation, we should reset the reported event
weight to unity (signed) or zero. The latter case is appropriate for
an event which failed for whatever reason.
<<Instances: process instance: TBP>>=
procedure :: normalize_weight => process_instance_normalize_weight
<<Instances: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_instance_recover &
(instance, channel, i_term, update_sqme, recover_phs, scale_forced)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: channel
integer, intent(in) :: i_term
logical, intent(in) :: update_sqme
logical, intent(in) :: recover_phs
real(default), intent(in), allocatable, optional :: scale_forced
logical :: skip_phs
call instance%activate ()
instance%evaluation_status = STAT_EFF_KINEMATICS
call instance%recover_hard_kinematics (i_term)
call instance%recover_seed_kinematics (i_term)
call instance%select_channel (channel)
if (recover_phs) then
call instance%recover_mcpar (i_term)
call instance%recover_beam_momenta (i_term)
call instance%compute_seed_kinematics (i_term)
call instance%compute_hard_kinematics (i_term)
call instance%compute_eff_kinematics (i_term)
call instance%compute_other_channels (i_term)
else
call instance%recover_sfchain (i_term)
end if
call instance%evaluate_expressions (scale_forced)
if (update_sqme) then
call instance%reset_core_kinematics ()
call instance%evaluate_trace ()
end if
end subroutine process_instance_recover
@ %def process_instance_recover
@ The [[evaluate]] method is required by the [[sampler_t]] base type of which
the process instance is an extension.
The requirement is that after the process instance is evaluated, the
integrand, the selected channel, the $x$ array, and the $f$ Jacobian array are
exposed by the [[sampler_t]] object.
We allow for the additional [[hook]] to be called, if associated, for outlying
object to access information from the current state of the [[sampler]].
<<Instances: process instance: TBP>>=
procedure :: evaluate => process_instance_evaluate
<<Instances: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_instance_fetch (sampler, val, x, f)
class(process_instance_t), intent(in) :: sampler
real(default), intent(out) :: val
real(default), dimension(:,:), intent(out) :: x
real(default), dimension(:), intent(out) :: f
integer, dimension(:), allocatable :: i_terms
integer :: i, i_term_base, cc
integer :: n_channel
val = 0
associate (process => sampler%process)
FIND_COMPONENT: do i = 1, process%get_n_components ()
if (sampler%process%component_is_selected (i)) then
allocate (i_terms (size (process%get_component_i_terms (i))))
i_terms = process%get_component_i_terms (i)
i_term_base = i_terms(1)
associate (k => sampler%term(i_term_base)%k_term)
n_channel = k%n_channel
do cc = 1, n_channel
call k%get_mcpar (cc, x(:,cc))
end do
f = k%f
val = sampler%sqme * k%phs_factor
end associate
if (allocated (i_terms)) deallocate (i_terms)
exit FIND_COMPONENT
end if
end do FIND_COMPONENT
end associate
end subroutine process_instance_fetch
@ %def process_instance_fetch
@ Initialize and finalize event generation for the specified MCI
entry.
<<Instances: process instance: TBP>>=
procedure :: init_simulation => process_instance_init_simulation
procedure :: final_simulation => process_instance_final_simulation
<<Instances: procedures>>=
subroutine process_instance_init_simulation (instance, i_mci, &
safety_factor, keep_failed_events)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
real(default), intent(in), optional :: safety_factor
logical, intent(in), optional :: keep_failed_events
call instance%mci_work(i_mci)%init_simulation (safety_factor, keep_failed_events)
end subroutine process_instance_init_simulation
subroutine process_instance_final_simulation (instance, i_mci)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_mci
call instance%mci_work(i_mci)%final_simulation ()
end subroutine process_instance_final_simulation
@ %def process_instance_init_simulation
@ %def process_instance_final_simulation
@
\subsubsection{Accessing the process instance}
Once the seed kinematics is complete, we can retrieve the MC input parameters
for all channels, not just the seed channel.
Note: We choose the first active component. This makes sense only if the seed
kinematics is identical for all active components.
<<Instances: process instance: TBP>>=
procedure :: get_mcpar => process_instance_get_mcpar
<<Instances: procedures>>=
subroutine process_instance_get_mcpar (instance, channel, x)
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: channel
real(default), dimension(:), intent(out) :: x
integer :: i
if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then
do i = 1, size (instance%term)
if (instance%term(i)%active) then
call instance%term(i)%k_term%get_mcpar (channel, x)
return
end if
end do
call msg_bug ("Process instance: get_mcpar: no active channels")
else
call msg_bug ("Process instance: get_mcpar: no seed kinematics")
end if
end subroutine process_instance_get_mcpar
@ %def process_instance_get_mcpar
@ Return true if the [[sqme]] value is known. This also implies that the
event is kinematically valid and has passed all cuts.
<<Instances: process instance: TBP>>=
procedure :: has_evaluated_trace => process_instance_has_evaluated_trace
<<Instances: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
function process_instance_get_trace_int_ptr (instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(interaction_t), pointer :: ptr
ptr => instance%term(i_term)%connected%get_trace_int_ptr ()
end function process_instance_get_trace_int_ptr
function process_instance_get_matrix_int_ptr (instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(interaction_t), pointer :: ptr
ptr => instance%term(i_term)%connected%get_matrix_int_ptr ()
end function process_instance_get_matrix_int_ptr
function process_instance_get_flows_int_ptr (instance, i_term) result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(interaction_t), pointer :: ptr
ptr => instance%term(i_term)%connected%get_flows_int_ptr ()
end function process_instance_get_flows_int_ptr
@ %def process_instance_get_trace_int_ptr
@ %def process_instance_get_matrix_int_ptr
@ %def process_instance_get_flows_int_ptr
@ Return the complete account of flavor combinations in the underlying
interaction object, including beams, radiation, and hard interaction.
<<Instances: process instance: TBP>>=
procedure :: get_state_flv => process_instance_get_state_flv
<<Instances: procedures>>=
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: procedures>>=
function process_instance_get_isolated_state_ptr (instance, i_term) &
result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(isolated_state_t), pointer :: ptr
ptr => instance%term(i_term)%isolated
end function process_instance_get_isolated_state_ptr
function process_instance_get_connected_state_ptr (instance, i_term) &
result (ptr)
class(process_instance_t), intent(in), target :: instance
integer, intent(in) :: i_term
type(connected_state_t), pointer :: ptr
ptr => instance%term(i_term)%connected
end function process_instance_get_connected_state_ptr
@ %def process_instance_get_isolated_state_ptr
@ %def process_instance_get_connected_state_ptr
@ Return the indices of the beam particles and incoming partons within the
currently active state matrix, respectively.
<<Instances: process instance: TBP>>=
procedure :: get_beam_index => process_instance_get_beam_index
procedure :: get_in_index => process_instance_get_in_index
<<Instances: procedures>>=
subroutine process_instance_get_beam_index (instance, i_term, i_beam)
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
integer, dimension(:), intent(out) :: i_beam
call instance%term(i_term)%connected%get_beam_index (i_beam)
end subroutine process_instance_get_beam_index
subroutine process_instance_get_in_index (instance, i_term, i_in)
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
integer, dimension(:), intent(out) :: i_in
call instance%term(i_term)%connected%get_in_index (i_in)
end subroutine process_instance_get_in_index
@ %def process_instance_get_beam_index
@ %def process_instance_get_in_index
@ Return squared matrix element and event weight, and event weight
excess where applicable. [[n_dropped]] is a number that can be
nonzero when a weighted event has been generated, dropping events with
zero weight (failed cuts) on the fly.
<<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: procedures>>=
function process_instance_get_sqme (instance, i_term) result (sqme)
real(default) :: sqme
class(process_instance_t), intent(in) :: instance
integer, intent(in), optional :: i_term
if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then
if (present (i_term)) then
sqme = instance%term(i_term)%connected%trace%get_matrix_element (1)
else
sqme = instance%sqme
end if
else
sqme = 0
end if
end function process_instance_get_sqme
function process_instance_get_weight (instance) result (weight)
real(default) :: weight
class(process_instance_t), intent(in) :: instance
if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
weight = instance%weight
else
weight = 0
end if
end function process_instance_get_weight
function process_instance_get_excess (instance) result (excess)
real(default) :: excess
class(process_instance_t), intent(in) :: instance
if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
excess = instance%excess
else
excess = 0
end if
end function process_instance_get_excess
function process_instance_get_n_dropped (instance) result (n_dropped)
integer :: n_dropped
class(process_instance_t), intent(in) :: instance
if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
n_dropped = instance%n_dropped
else
n_dropped = 0
end if
end function process_instance_get_n_dropped
@ %def process_instance_get_sqme
@ %def process_instance_get_weight
@ %def process_instance_get_excess
@ %def process_instance_get_n_dropped
@ Return the currently selected MCI channel.
<<Instances: process instance: TBP>>=
procedure :: get_channel => process_instance_get_channel
<<Instances: procedures>>=
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: procedures>>=
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: procedures>>=
function process_instance_get_fac_scale (instance, i_term) result (fac_scale)
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
real(default) :: fac_scale
fac_scale = instance%term(i_term)%get_fac_scale ()
end function process_instance_get_fac_scale
function process_instance_get_alpha_s (instance, i_term) result (alpha_s)
real(default) :: alpha_s
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
class(prc_core_t), pointer :: core => null ()
core => instance%process%get_core_term (i_term)
alpha_s = instance%term(i_term)%get_alpha_s (core)
core => null ()
end function process_instance_get_alpha_s
@ %def process_instance_get_fac_scale
@ %def process_instance_get_alpha_s
@
<<Instances: process instance: TBP>>=
procedure :: get_qcd => process_instance_get_qcd
<<Instances: procedures>>=
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: procedures>>=
subroutine process_instance_reset_counter (process_instance)
class(process_instance_t), intent(inout) :: process_instance
call process_instance%mci_work(process_instance%i_mci)%reset_counter ()
end subroutine process_instance_reset_counter
subroutine process_instance_record_call (process_instance)
class(process_instance_t), intent(inout) :: process_instance
call process_instance%mci_work(process_instance%i_mci)%record_call &
(process_instance%evaluation_status)
end subroutine process_instance_record_call
pure function process_instance_get_counter (process_instance) result (counter)
class(process_instance_t), intent(in) :: process_instance
type(process_counter_t) :: counter
counter = process_instance%mci_work(process_instance%i_mci)%get_counter ()
end function process_instance_get_counter
@ %def process_instance_reset_counter
@ %def process_instance_record_call
@ %def process_instance_get_counter
@ Sum up the total number of calls for all MCI records.
<<Instances: process instance: TBP>>=
procedure :: get_actual_calls_total => process_instance_get_actual_calls_total
<<Instances: procedures>>=
pure function process_instance_get_actual_calls_total (process_instance) &
result (n)
class(process_instance_t), intent(in) :: process_instance
integer :: n
integer :: i
type(process_counter_t) :: counter
n = 0
do i = 1, size (process_instance%mci_work)
counter = process_instance%mci_work(i)%get_counter ()
n = n + counter%total
end do
end function process_instance_get_actual_calls_total
@ %def process_instance_get_actual_calls_total
@
<<Instances: process instance: TBP>>=
procedure :: reset_matrix_elements => process_instance_reset_matrix_elements
<<Instances: procedures>>=
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: procedures>>=
subroutine process_instance_get_test_phase_space_point (instance, &
i_component, i_core, p)
type(vector4_t), dimension(:), allocatable, intent(out) :: p
class(process_instance_t), intent(inout) :: instance
integer, intent(in) :: i_component, i_core
real(default), dimension(:), allocatable :: x
logical :: success
integer :: i_term
instance%i_mci = i_component
i_term = instance%process%get_i_term (i_core)
associate (term => instance%term(i_term))
allocate (x (instance%mci_work(i_component)%config%n_par))
x = 0.5_default
call instance%set_mcpar (x, .true.)
call instance%select_channel (1)
call term%compute_seed_kinematics &
(instance%mci_work(i_component), 1, success)
call instance%term(i_term)%evaluate_radiation_kinematics &
(instance%mci_work(instance%i_mci)%get_x_process ())
call instance%term(i_term)%compute_hard_kinematics (success = success)
allocate (p (size (term%p_hard)))
p = term%int_hard%get_momenta ()
end associate
end subroutine process_instance_get_test_phase_space_point
@ %def process_instance_get_test_phase_space_point
@
<<Instances: process instance: TBP>>=
procedure :: get_p_hard => process_instance_get_p_hard
<<Instances: procedures>>=
pure function process_instance_get_p_hard (process_instance, i_term) &
result (p_hard)
type(vector4_t), dimension(:), allocatable :: p_hard
class(process_instance_t), intent(in) :: process_instance
integer, intent(in) :: i_term
allocate (p_hard (size (process_instance%term(i_term)%get_p_hard ())))
p_hard = process_instance%term(i_term)%get_p_hard ()
end function process_instance_get_p_hard
@ %def process_instance_get_p_hard
@
<<Instances: process instance: TBP>>=
procedure :: get_first_active_i_term => process_instance_get_first_active_i_term
<<Instances: procedures>>=
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: procedures>>=
function process_instance_get_real_of_mci (instance) result (i_real)
integer :: i_real
class(process_instance_t), intent(in) :: instance
select type (pcm => instance%pcm)
type is (pcm_instance_nlo_t)
i_real = pcm%i_mci_to_real_component (instance%i_mci)
end select
end function process_instance_get_real_of_mci
@ %def process_instance_get_real_of_mci
@
<<Instances: process instance: TBP>>=
procedure :: get_connected_states => process_instance_get_connected_states
<<Instances: procedures>>=
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: procedures>>=
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: procedures>>=
function process_instance_get_polarization (instance) result (pol)
class(process_instance_t), intent(in) :: instance
real(default), dimension(2) :: pol
pol = instance%process%get_polarization ()
end function process_instance_get_polarization
@ %def process_instance_get_polarization
@ Get the beam spectrum
<<Instances: process instance: TBP>>=
procedure :: get_beam_file => process_instance_get_beam_file
<<Instances: procedures>>=
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: procedures>>=
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: procedures>>=
subroutine process_instance_get_trace (instance, pset, i_term, n_incoming)
class(process_instance_t), intent(in), target :: instance
type(particle_set_t), intent(out) :: pset
integer, intent(in) :: i_term
integer, intent(in), optional :: n_incoming
type(interaction_t), pointer :: int
logical :: ok
int => instance%get_trace_int_ptr (i_term)
call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
[0._default, 0._default], .false., .true., n_incoming)
end subroutine process_instance_get_trace
subroutine process_instance_set_trace &
(instance, pset, i_term, recover_beams, check_match)
class(process_instance_t), intent(inout), target :: instance
type(particle_set_t), intent(in) :: pset
integer, intent(in) :: i_term
logical, intent(in), optional :: recover_beams, check_match
type(interaction_t), pointer :: int
integer :: n_in
int => instance%get_trace_int_ptr (i_term)
n_in = instance%process%get_n_in ()
call pset%fill_interaction (int, n_in, &
recover_beams = recover_beams, &
check_match = check_match, &
state_flv = instance%get_state_flv (i_term))
end subroutine process_instance_set_trace
@ %def process_instance_get_trace
@ %def process_instance_set_trace
@ This procedure allows us to override any QCD setting of the WHIZARD process
and directly set the coupling value that comes together with a particle set.
<<Instances: process instance: TBP>>=
procedure :: set_alpha_qcd_forced => process_instance_set_alpha_qcd_forced
<<Instances: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
function process_instance_get_boost_to_lab (instance, i_term) result (lt)
type(lorentz_transformation_t) :: lt
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
lt = instance%term(i_term)%get_boost_to_lab ()
end function process_instance_get_boost_to_lab
@ %def process_instance_get_boost_to_lab
@
<<Instances: process instance: TBP>>=
procedure :: get_boost_to_cms => process_instance_get_boost_to_cms
<<Instances: procedures>>=
function process_instance_get_boost_to_cms (instance, i_term) result (lt)
type(lorentz_transformation_t) :: lt
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
lt = instance%term(i_term)%get_boost_to_cms ()
end function process_instance_get_boost_to_cms
@ %def process_instance_get_boost_to_cms
@
<<Instances: process instance: TBP>>=
procedure :: is_cm_frame => process_instance_is_cm_frame
<<Instances: procedures>>=
function process_instance_is_cm_frame (instance, i_term) result (cm_frame)
logical :: cm_frame
class(process_instance_t), intent(in) :: instance
integer, intent(in) :: i_term
cm_frame = instance%term(i_term)%k_term%phs%is_cm_frame ()
end function process_instance_is_cm_frame
@ %def protcess_instance_is_cm_frame
@
The [[pacify]] subroutine has the purpose of setting numbers to zero
which are (by comparing with a [[tolerance]] parameter) considered
equivalent with zero. We do this in some unit tests. Here, we a
apply this to the phase space subobject of the process instance.
<<Instances: public>>=
public :: pacify
<<Instances: interfaces>>=
interface pacify
module procedure pacify_process_instance
end interface pacify
<<Instances: procedures>>=
subroutine pacify_process_instance (instance)
type(process_instance_t), intent(inout) :: instance
integer :: i
do i = 1, size (instance%term)
call pacify (instance%term(i)%k_term%phs)
end do
end subroutine pacify_process_instance
@ %def pacify
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[processes_ut.f90]]>>=
<<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 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 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%term(1)%k_term%phs_factor
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process_instance%final ()
deallocate (process_instance)
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_11"
end subroutine processes_11
@ %def processes_11
@
\subsubsection{Complete events}
For the purpose of simplifying further tests, we implement a
convenience routine that initializes a process and prepares a single
event. This is a wrapup of the test [[processes_10]].
The procedure is re-exported by the [[processes_ut]] module.
<<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%term(1)%k_term%phs_factor
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call process_instance%final ()
deallocate (process_instance)
call process%final ()
deallocate (process)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: processes_16"
end subroutine processes_16
@ %def processes_16
@ MCI record prepared for midpoint integrator.
<<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)
class(process_instance_hook_test_t), intent(inout), target :: hook
type(var_list_t), intent(in) :: var_list
class(process_instance_t), intent(in), target :: instance
end subroutine process_instance_hook_test_init
subroutine process_instance_hook_test_final (hook)
class(process_instance_hook_test_t), intent(inout) :: hook
end subroutine process_instance_hook_test_final
subroutine process_instance_hook_test_evaluate (hook, instance)
class(process_instance_hook_test_t), intent(inout) :: hook
class(process_instance_t), intent(in), target :: instance
write (hook%unit, "(A)") "Execute hook:"
write (hook%unit, "(2X,A,1X,A,I0,A)") hook%name, "(", len (trim (hook%name)), ")"
end subroutine process_instance_hook_test_evaluate
@
<<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 io_units
use format_utils, only: write_separator
use diagnostics
use os_interface
use sm_qcd
use model_data
use rng_base
use variables
use observables
use process_libraries
use process
<<Standard module head>>
<<Process stacks: public>>
<<Process stacks: types>>
contains
<<Process stacks: procedures>>
end module process_stacks
@ %def process_stacks
@
\subsection{The process entry type}
A process entry is a process object, augmented by a pointer to the
next entry. We do not need specific methods, all relevant methods are
inherited.
On higher level, processes should be prepared as process entry objects.
<<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: procedures>>=
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: procedures>>=
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: procedures>>=
recursive subroutine process_stack_write (object, unit, pacify)
class(process_stack_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: pacify
type(process_entry_t), pointer :: process
integer :: u
u = given_output_unit (unit)
call write_separator (u, 2)
select case (object%n)
case (0)
write (u, "(1x,A)") "Process stack: [empty]"
call write_separator (u, 2)
case default
write (u, "(1x,A)") "Process stack:"
process => object%first
do while (associated (process))
call process%write (.false., u, pacify = pacify)
process => process%next
end do
end select
if (associated (object%next)) then
write (u, "(1x,A)") "[Processes from context environment:]"
call object%next%write (u, pacify)
end if
end subroutine process_stack_write
@ %def process_stack_write
@ The variable list is printed by a separate routine, since
it should be linked to the global variable list, anyway.
<<Process stacks: process stack: TBP>>=
procedure :: write_var_list => process_stack_write_var_list
<<Process stacks: procedures>>=
subroutine process_stack_write_var_list (object, unit)
class(process_stack_t), intent(in) :: object
integer, intent(in), optional :: unit
if (associated (object%var_list)) then
call var_list_write (object%var_list, unit)
end if
end subroutine process_stack_write_var_list
@ %def process_stack_write_var_list
@ Short output.
Since this is a stack, the default output ordering for each stack will be
last-in, first-out. To enable first-in, first-out, which is more likely to be
requested, there is an optional [[fifo]] argument.
<<Process stacks: process stack: TBP>>=
procedure :: show => process_stack_show
<<Process stacks: procedures>>=
recursive subroutine process_stack_show (object, unit, fifo)
class(process_stack_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: fifo
type(process_entry_t), pointer :: process
logical :: reverse
integer :: u, i, j
u = given_output_unit (unit)
reverse = .false.; if (present (fifo)) reverse = fifo
select case (object%n)
case (0)
case default
if (.not. reverse) then
process => object%first
do while (associated (process))
call process%show (u, verbose=.false.)
process => process%next
end do
else
do i = 1, object%n
process => object%first
do j = 1, object%n - i
process => process%next
end do
call process%show (u, verbose=.false.)
end do
end if
end select
if (associated (object%next)) call object%next%show ()
end subroutine process_stack_show
@ %def process_stack_show
@
\subsection{Link}
Link the current process stack to a global one.
<<Process stacks: process stack: TBP>>=
procedure :: link => process_stack_link
<<Process stacks: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
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: procedures>>=
recursive function process_stack_get_process_ptr (stack, id) result (ptr)
class(process_stack_t), intent(in) :: stack
type(string_t), intent(in) :: id
type(process_t), pointer :: ptr
type(process_entry_t), pointer :: entry
ptr => null ()
entry => stack%first
do while (associated (entry))
if (entry%get_id () == id) then
ptr => entry%process_t
return
end if
entry => entry%next
end do
if (associated (stack%next)) ptr => stack%next%get_process_ptr (id)
end function process_stack_get_process_ptr
@ %def process_stack_get_process_ptr
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[process_stacks_ut.f90]]>>=
<<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/fks/fks.nw
===================================================================
--- trunk/src/fks/fks.nw (revision 8249)
+++ trunk/src/fks/fks.nw (revision 8250)
@@ -1,9655 +1,9704 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: matrix elements and process libraries
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{FKS Subtraction Scheme}
\includemodulegraph{fks}
The code in this chapter implements the FKS subtraction scheme for use
with \whizard.
These are the modules:
\begin{description}
\item[fks\_regions]
Given a process definition, identify singular regions in the
associated phase space.
\item[virtual]
Handle the virtual correction matrix element.
\item[real\_subtraction]
Handle the real-subtraction matrix element.
\item[nlo\_data]
Manage the subtraction objects.
\end{description}
This chapter deals with next-to-leading order contributions to cross sections.
Basically, there are three major issues to be adressed: The creation
of the $N+1$-particle flavor structure, the construction of the
$N+1$-particle phase space and the actual calculation of the real- and
virtual-subtracted matrix elements. The first is dealt with using the
[[auto_components]] class, and it will be shown that the second
and third issue are connected in FKS subtraction.
\section{Brief outline of FKS subtraction}
{\em In the current state, this discussion is only concerned with
lepton collisions. For hadron collisions, renormalization of parton
distributions has to be taken into account. Further, for QCD
corrections, initial-state radiation is necessarily
present. However, most quantities have so far been only constructed
for final-state emissions}
The aim is to calculate the next-to-leading order cross section
according to
\begin{equation*}
d\sigma_{\rm{NLO}} = \mathcal{B} + \mathcal{V} +
\mathcal{R}d\Phi_{\rm{rad}}.
\end{equation*}
Analytically, the divergences, in terms of poles in the complex
quantity $\varepsilon = 2-d/2$, cancel. However, this is in general
only valid in an arbitrary, comlex number of dimensions. This is,
roughly, the content of the KLN-theorem. \whizard, as any
other numerical program, is confined to four dimensions. We will
assume that the KLN-theorem is valid and that there exist subtraction
terms $\mathcal{C}$ such that
\begin{equation*}
d\sigma_{\rm{NLO}} = \mathcal{B} + \underbrace{\mathcal{V} +
\mathcal{C}}_{\text{finite}} + \underbrace{\mathcal{R} -
\mathcal{C}}_{\text{finite}},
\end{equation*}
i.e. the subtraction terms correspond to the divergent limits of the
real and virtual matrix element.
Because $\mathcal{C}$ subtracts the divergences of $\mathcal{R}$ as
well as those of $\mathcal{V}$, it suffices to consider one of them,
so we focus on $\mathcal{R}$. For this purpose, $\mathcal{R}$ is
rewritten,
\begin{equation*}
\mathcal{R} = \frac{1}{\xi^2}\frac{1}{1-y} \left(\xi^2
(1-y)\mathcal{R}\right) =
\frac{1}{\xi^2}\frac{1}{1-y}\tilde{\mathcal{R}},
\end{equation*}
with $\xi = \left(2k_{\rm{rad}}^0\right)/\sqrt{s}$ and $y =
\cos\theta$, where $k_{\rm{rad}}^0$ denotes the energy of the radiated
parton and $\theta$ is the angle between emitter and radiated
parton. $\tilde{\mathcal{R}}$ is finite, therefore the whole
singularity structure is contained in the prefactor
$\xi^{-2}(1-y)^{-1}$. Combined with the d-dimensional phase space
element,
\begin{equation*}
\frac{d^{d-1}k}{2k^0(2\pi)^{d-1}} =
\frac{s^{1-\varepsilon}}{(4\pi)^{d-1}}\xi^{1-2\varepsilon}\left(1-y^2\right)^{-\varepsilon}
d\xi dy d\Omega^{d-2},
\end{equation*}
this yields
\begin{equation*}
d\Phi_{\rm{rad}} \mathcal{R} = dy (1-y)^{-1-\varepsilon} d\xi
\xi^{-1-2\varepsilon} \tilde{R}.
\end{equation*}
This can further be rewritten in terms of plus-distributions,
\begin{align*}
\xi^{-1-2\varepsilon} &= -\frac{1}{2\varepsilon}\delta(\xi) +
\left(\frac{1}{\xi}\right)_+ -
2\varepsilon\left(\frac{\log\xi}{\xi}\right)_+ +
\mathcal{O}(\varepsilon^2),\\
(1-y)^{-1-\varepsilon} &= -\frac{2^{-\varepsilon}}{\varepsilon}
\delta(1-y) + \left(\frac{1}{1-y}\right)_+ - \varepsilon
\left(\frac{1}{1-y}\right)_+\log(1-y) + \mathcal{O}(\varepsilon^2),
\end{align*}
(imagine that all this is written inside of integrals, which are
spared for ease of notation) such that
\begin{align*}
d\Phi_{\rm{rad}} \mathcal{R} &= -\frac{1}{2\varepsilon} dy
(1-y)^{-1-\varepsilon}\tilde{R} (0,y) -
d\xi\left[\frac{2^{-\varepsilon}}{\varepsilon}\left(\frac{1}{\xi}\right)_+
- 2\left(\frac{\log\xi}{\xi}\right)_+\right] \tilde{R}(\xi,1) \\
&+ dy d\xi \left(\frac{1}{\xi}\right)_+
\left(\frac{1}{1-y}\right)_+
\tilde{R}(\xi, y) +
\mathcal{O}(\varepsilon).\\
\end{align*}
The summand in the second line is of order $\mathcal{O}(1)$ and is the
only one to reproduce $\mathcal{R}(\xi,y)$. It thus constitutes the
sum of the real matrix element and the corresponding counterterms.
The first summand consequently consists of the subtraction terms to
the virtual matrix elements. Above formula thus allows to calculate
all quantities to render the matrix elements finite.
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Identifying singular regions}
In the FKS subtraction scheme, the phase space is decomposed into
disjoint singular regions, such that
\begin{equation}
\label{eq:S_complete}
\sum_i \mathcal{S}_i + \sum_{ij}\mathcal{S}_{ij} = 1.
\end{equation}
The quantities $\mathcal{S}_i$ and $\mathcal{S}_{ij}$ are functions of
phase space corresponding to a pair of particles indices which can
make up a divergent phase space region. We call such an index pair a
fundamental tuple. For example, the process $e^+ \, e^- \rightarrow u
\, \bar{u} \, g$ has two singular regions, $(3,5)$ and $(4,5)$,
indicating that the gluon can be soft or collinear with respect to
either the quark or the anti-quark. Therefore, the functions $S_{ij}$
have to be chosen in such a way that their contribution makes up most
of \eqref{eq:S_complete} in phase-space configurations where
(final-state) particle $j$ is collinear to particle $i$ or/and
particle $j$ is soft. The functions $S_i$ is the corresponding
quantity for initial-state divergences.
As a singular region we understand the collection of real flavor
structures associated with an emitter and a list of all possible
fundamental tuples. As an example, consider the process $e^+ \, e^-
\rightarrow u \, \bar{u} \, g$. At next-to-leading order, processes
with an additionally radiated particle have to be considered. In this
case, these are $e^+ \, e^- \rightarrow u \, \bar{u}, \, g \, g$,
and $e^+ \, e^- \rightarrow u \, \bar{u} \, u \, \bar{u}$ (or the same
process with any other quark). Table \ref{table:singular regions} sums
up all possible singular regions for this problem.
\begin{table}
\begin{tabular}{|c|c|c|c|}
\hline
\texttt{alr} & \texttt{flst\_alr} & \texttt{emi} &
\texttt{ftuple\_list}\\ \hline
1 & [-11,11,2,-2,21,21] & 3 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline
2 & [-11,11,2,-2,21,21] & 4 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline
3 & [-11,11,2,-2,21,21] & 5 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline
4 & [-11,11,2,-2,2,-2] & 5 & {(5,6)} \\
\hline
\end{tabular}
\caption{List of singular regions. The particles are represented by
their PDG codes. The third column contains the emitter for the
specific singular region. For the process involving an additional
gluon, the gluon can either be emitted from one of the quarks or
from the first gluon. Each emitter yields the same list of
fundamental tuples, five in total. The last singular region
corresponds to the process where the gluon splits up into two
quarks. Here, there is only one fundamental tuple, corresponding to
a singular configuration of the momenta of the additional quarks.}
\label{table:singular regions}
\end{table}
\\
\begin{table}
\begin{tabular}{|c|c|c|c|}
\hline
\texttt{alr} & \texttt{ftuple} & \texttt{emitter} &
\texttt{flst\_alr} \\ \hline
1 & $(3,5)$ & 5 & [-11,11,-2,21,2,21] \\ \hline
2 & $(4,5)$ & 5 & [-11,11,2,21,-2,21] \\ \hline
3 & $(3,6)$ & 5 & [-11,11,-2,21,2,21] \\ \hline
4 & $(4,6)$ & 5 & [-11,11,2,21,-2,21] \\ \hline
5 & $(5,6)$ & 5 & [-11,11,2,-2,21,21] \\ \hline
6 & $(5,6)$ & 5 & [-11,11,2,-2,2,-2] \\ \hline
\end{tabular}
\caption{Initial list of singular regions}
\label{table:ftuples and flavors}
\end{table}
Thus, during the preparation of a NLO-calculation, the possible
singular regions have to be identified. [[fks_regions.f90]] deals
with this issue.
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{FKS Regions}
<<[[fks_regions.f90]]>>=
<<File header>>
module fks_regions
<<Use kinds>>
use format_utils, only: write_separator
- use numeric_utils, only: remove_duplicates_from_list, extend_integer_array
- use numeric_utils, only: remove_duplicates_from_list
+ use numeric_utils, only: remove_duplicates_from_int_array, extend_integer_array
use string_utils, only: str
use io_units
use os_interface
<<Use strings>>
<<Use debug>>
use constants
use permutations
use diagnostics
use flavors
use process_constants
use lorentz
use pdg_arrays
use models
use physics_defs
use resonances, only: resonance_contributors_t, resonance_history_t
use phs_fks, only: phs_identifier_t, check_for_phs_identifier
use nlo_data
<<Standard module head>>
<<fks regions: public>>
<<fks regions: parameters>>
<<fks regions: types>>
<<fks regions: interfaces>>
contains
<<fks regions: procedures>>
end module fks_regions
@ %def fks_regions
@ There are three fundamental splitting types: $q \rightarrow qg$, $g \rightarrow gg$ and
$g \rightarrow qq$.
<<fks regions: parameters>>=
integer, parameter :: UNDEFINED_SPLITTING = 0
integer, parameter :: F_TO_FV = 1
integer, parameter :: V_TO_VV = 2
integer, parameter :: V_TO_FF = 3
@
@ We group the indices of the emitting and the radiated particle in
the [[ftuple]]-object.
<<fks regions: public>>=
public :: ftuple_t
<<fks regions: types>>=
type :: ftuple_t
integer, dimension(2) :: ireg = [-1,-1]
integer :: i_res = 0
integer :: splitting_type
logical :: pseudo_isr = .false.
contains
<<fks regions: ftuple: TBP>>
end type ftuple_t
@ %def ftuple_t
@
<<fks regions: interfaces>>=
interface assignment(=)
module procedure ftuple_assign
end interface
interface operator(==)
module procedure ftuple_equal
end interface
<<fks regions: procedures>>=
pure subroutine ftuple_assign (ftuple_out, ftuple_in)
type(ftuple_t), intent(out) :: ftuple_out
type(ftuple_t), intent(in) :: ftuple_in
ftuple_out%ireg = ftuple_in%ireg
ftuple_out%i_res = ftuple_in%i_res
ftuple_out%splitting_type = ftuple_in%splitting_type
ftuple_out%pseudo_isr = ftuple_in%pseudo_isr
end subroutine ftuple_assign
@ %def ftuple_assign
@
<<fks regions: procedures>>=
elemental function ftuple_equal (f1, f2) result (value)
logical :: value
type(ftuple_t), intent(in) :: f1, f2
value = all (f1%ireg == f2%ireg) .and. f1%i_res == f2%i_res &
.and. f1%splitting_type == f2%splitting_type &
.and. (f1%pseudo_isr .eqv. f2%pseudo_isr)
end function ftuple_equal
@ %def ftuple_equal
@
<<fks regions: procedures>>=
elemental function ftuple_compare (f1, f2) result (greater)
logical :: greater
type(ftuple_t), intent(in) :: f1, f2
if (f1%ireg(1) == f2%ireg(1)) then
greater = f1%ireg(2) > f2%ireg(2)
else
greater = f1%ireg(1) > f2%ireg(2)
end if
end function ftuple_compare
@ %def ftuple_compare
@
<<fks regions: ftuple: TBP>>=
procedure :: write => ftuple_write
<<fks regions: procedures>>=
subroutine ftuple_write (ftuple, unit, newline)
class(ftuple_t), intent(in) :: ftuple
integer, intent(in), optional :: unit
logical, intent(in), optional :: newline
integer :: u
logical :: nl
u = given_output_unit (unit); if (u < 0) return
nl = .true.; if (present(newline)) nl = newline
if (all (ftuple%ireg > -1)) then
if (ftuple%i_res > 0) then
if (nl) then
write (u, "(A1,I1,A1,I1,A1,I1,A1)") &
'(', ftuple%ireg(1), ',', ftuple%ireg(2), ';', ftuple%i_res, ')'
else
write (u, "(A1,I1,A1,I1,A1,I1,A1)", advance = "no") &
'(', ftuple%ireg(1), ',', ftuple%ireg(2), ';', ftuple%i_res, ')'
end if
else
if (nl) then
write (u, "(A1,I1,A1,I1,A1)") &
'(', ftuple%ireg(1), ',', ftuple%ireg(2), ')'
else
write (u, "(A1,I1,A1,I1,A1)", advance = "no") &
'(', ftuple%ireg(1), ',', ftuple%ireg(2), ')'
end if
end if
else
write (u, "(A)") "(Empty)"
end if
end subroutine ftuple_write
@ %def ftuple_write
@
<<fks regions: procedures>>=
function ftuple_string (ftuples, latex)
type(string_t) :: ftuple_string
type(ftuple_t), intent(in), dimension(:) :: ftuples
logical, intent(in) :: latex
integer :: i, nreg
if (latex) then
ftuple_string = var_str ("$\left\{")
else
ftuple_string = var_str ("{")
end if
nreg = size(ftuples)
do i = 1, nreg
if (ftuples(i)%i_res == 0) then
ftuple_string = ftuple_string // var_str ("(") // &
str (ftuples(i)%ireg(1)) // var_str (",") // &
str (ftuples(i)%ireg(2)) // var_str (")")
else
ftuple_string = ftuple_string // var_str ("(") // &
str (ftuples(i)%ireg(1)) // var_str (",") // &
str (ftuples(i)%ireg(2)) // var_str (";") // &
str (ftuples(i)%i_res) // var_str (")")
end if
if (ftuples(i)%pseudo_isr) ftuple_string = ftuple_string // var_str ("*")
if (i < nreg) ftuple_string = ftuple_string // var_str (",")
end do
if (latex) then
ftuple_string = ftuple_string // var_str ("\right\}$")
else
ftuple_string = ftuple_string // var_str ("}")
end if
end function ftuple_string
@ %def ftuple_string
@
<<fks regions: ftuple: TBP>>=
procedure :: get => ftuple_get
<<fks regions: procedures>>=
subroutine ftuple_get (ftuple, pos1, pos2)
class(ftuple_t), intent(in) :: ftuple
integer, intent(out) :: pos1, pos2
pos1 = ftuple%ireg(1)
pos2 = ftuple%ireg(2)
end subroutine ftuple_get
@ %def ftuple_get
@
<<fks regions: ftuple: TBP>>=
procedure :: set => ftuple_set
<<fks regions: procedures>>=
subroutine ftuple_set (ftuple, pos1, pos2)
class(ftuple_t), intent(inout) :: ftuple
integer, intent(in) :: pos1, pos2
ftuple%ireg(1) = pos1
ftuple%ireg(2) = pos2
end subroutine ftuple_set
@ %def ftuple_set
@
<<fks regions: ftuple: TBP>>=
procedure :: determine_splitting_type_fsr => ftuple_determine_splitting_type_fsr
<<fks regions: procedures>>=
subroutine ftuple_determine_splitting_type_fsr (ftuple, flv, i, j)
class(ftuple_t), intent(inout) :: ftuple
type(flv_structure_t), intent(in) :: flv
integer, intent(in) :: i, j
associate (flst => flv%flst)
if (is_vector (flst(i)) .and. is_vector (flst(j))) then
ftuple%splitting_type = V_TO_VV
else if (flst(i)+flst(j) == 0 &
.and. is_fermion (abs(flst(i)))) then
ftuple%splitting_type = V_TO_FF
else if (is_fermion(abs(flst(i))) .and. is_massless_vector (flst(j)) &
.or. is_fermion(abs(flst(j))) .and. is_massless_vector (flst(i))) then
ftuple%splitting_type = F_TO_FV
else
ftuple%splitting_type = UNDEFINED_SPLITTING
end if
end associate
end subroutine ftuple_determine_splitting_type_fsr
@ %def ftuple_determine_splitting_type_fsr
@
<<fks regions: ftuple: TBP>>=
procedure :: determine_splitting_type_isr => ftuple_determine_splitting_type_isr
<<fks regions: procedures>>=
subroutine ftuple_determine_splitting_type_isr (ftuple, flv, i, j)
class(ftuple_t), intent(inout) :: ftuple
type(flv_structure_t), intent(in) :: flv
integer, intent(in) :: i, j
integer :: em
em = i; if (i == 0) em = 1
associate (flst => flv%flst)
if (is_vector (flst(em)) .and. is_vector (flst(j))) then
ftuple%splitting_type = V_TO_VV
else if (is_massless_vector (flst(em)) .and. is_fermion(abs(flst(j)))) then
ftuple%splitting_type = V_TO_FF
else if (is_fermion(abs(flst(em))) .and. is_massless_vector (flst(j))) then
ftuple%splitting_type = F_TO_FV
else
ftuple%splitting_type = UNDEFINED_SPLITTING
end if
end associate
end subroutine ftuple_determine_splitting_type_isr
@ %def ftuple_determine_splitting_type_isr
@ Two debug functions to check the consistency of [[ftuples]]
<<fks regions: ftuple: TBP>>=
procedure :: has_negative_elements => ftuple_has_negative_elements
procedure :: has_identical_elements => ftuple_has_identical_elements
<<fks regions: procedures>>=
elemental function ftuple_has_negative_elements (ftuple) result (value)
logical :: value
class(ftuple_t), intent(in) :: ftuple
value = any (ftuple%ireg < 0)
end function ftuple_has_negative_elements
elemental function ftuple_has_identical_elements (ftuple) result (value)
logical :: value
class(ftuple_t), intent(in) :: ftuple
value = ftuple%ireg(1) == ftuple%ireg(2)
end function ftuple_has_identical_elements
@ %def ftuple_has_negative_elements, ftuple_has_identical_elements
@ Each singular region can have a different number of
emitter-radiation pairs. This is coped with using the linked list
[[ftuple_list]].
<<fks regions: types>>=
type :: ftuple_list_t
integer :: index = 0
type(ftuple_t) :: ftuple
type(ftuple_list_t), pointer :: next => null ()
type(ftuple_list_t), pointer :: prev => null ()
type(ftuple_list_t), pointer :: equiv => null ()
contains
<<fks regions: ftuple list: TBP>>
end type ftuple_list_t
@ %def ftuple_list_t
@
<<fks regions: ftuple list: TBP>>=
procedure :: write => ftuple_list_write
<<fks regions: procedures>>=
subroutine ftuple_list_write (list, unit, verbose)
class(ftuple_list_t), intent(in), target :: list
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
type(ftuple_list_t), pointer :: current
logical :: verb
integer :: u
u = given_output_unit (unit); if (u < 0) return
verb = .false.; if (present (verbose)) verb = verbose
select type (list)
type is (ftuple_list_t)
current => list
do
call current%ftuple%write (unit = u, newline = .false.)
if (verb .and. associated (current%equiv)) write (u, '(A)', advance = "no") "'"
if (associated (current%next)) then
current => current%next
else
exit
end if
end do
write (u, *) ""
end select
end subroutine ftuple_list_write
@ %def ftuple_list_write
@
<<fks regions: ftuple list: TBP>>=
procedure :: append => ftuple_list_append
<<fks regions: procedures>>=
subroutine ftuple_list_append (list, ftuple)
class(ftuple_list_t), intent(inout), target :: list
type(ftuple_t), intent(in) :: ftuple
type(ftuple_list_t), pointer :: current
select type (list)
type is (ftuple_list_t)
if (list%index == 0) then
nullify (list%next)
list%index = 1
list%ftuple = ftuple
else
current => list
do
if (associated (current%next)) then
current => current%next
else
allocate (current%next)
nullify (current%next%next)
nullify (current%next%equiv)
current%next%prev => current
current%next%index = current%index + 1
current%next%ftuple = ftuple
exit
end if
end do
end if
end select
end subroutine ftuple_list_append
@ %def ftuple_list_append
@
<<fks regions: ftuple list: TBP>>=
procedure :: compare => ftuple_list_compare
<<fks regions: procedures>>=
function ftuple_list_compare (ftuple_list, i1, i2) result (greater)
logical :: greater
class(ftuple_list_t), intent(in) :: ftuple_list
integer, intent(in) :: i1, i2
greater = ftuple_compare (ftuple_list%get_ftuple (i1), ftuple_list%get_ftuple (i2))
end function ftuple_list_compare
@ %def ftuple_list_compare
@
<<fks regions: ftuple list: TBP>>=
procedure :: get_n_tuples => ftuple_list_get_n_tuples
<<fks regions: procedures>>=
impure elemental function ftuple_list_get_n_tuples (list) result(n_tuples)
integer :: n_tuples
class(ftuple_list_t), intent(in), target :: list
type(ftuple_list_t), pointer :: current
n_tuples = 0
select type (list)
type is (ftuple_list_t)
current => list
if (current%index > 0) then
n_tuples = 1
do
if (associated (current%next)) then
current => current%next
n_tuples = n_tuples + 1
else
exit
end if
end do
end if
end select
end function ftuple_list_get_n_tuples
@ %def ftuple_list_get_n_tuples
@
<<fks regions: ftuple list: TBP>>=
procedure :: get_entry => ftuple_list_get_entry
<<fks regions: procedures>>=
function ftuple_list_get_entry (list, index) result (entry)
type(ftuple_list_t), pointer :: entry
class(ftuple_list_t), intent(in), target :: list
integer, intent(in) :: index
type(ftuple_list_t), pointer :: current
integer :: i
entry => null()
select type (list)
type is (ftuple_list_t)
current => list
if (index == 1) then
entry => current
else
do i = 1, index - 1
current => current%next
end do
entry => current
end if
end select
end function ftuple_list_get_entry
@ %def ftuple_list_get_entry
@
<<fks regions: ftuple list: TBP>>=
procedure :: get_ftuple => ftuple_list_get_ftuple
<<fks regions: procedures>>=
function ftuple_list_get_ftuple (list, index) result (ftuple)
type(ftuple_t) :: ftuple
class(ftuple_list_t), intent(in), target :: list
integer, intent(in) :: index
type(ftuple_list_t), pointer :: entry
entry => list%get_entry (index)
ftuple = entry%ftuple
end function ftuple_list_get_ftuple
@ %def ftuple_list_get_ftuple
@
<<fks regions: ftuple list: TBP>>=
procedure :: set_equiv => ftuple_list_set_equiv
<<fks regions: procedures>>=
subroutine ftuple_list_set_equiv (list, i1, i2)
class(ftuple_list_t), intent(in) :: list
integer, intent(in) :: i1, i2
type(ftuple_list_t), pointer :: list1, list2 => null ()
select type (list)
type is (ftuple_list_t)
if (list%compare (i1, i2)) then
list1 => list%get_entry (i2)
list2 => list%get_entry (i1)
else
list1 => list%get_entry (i1)
list2 => list%get_entry (i2)
end if
do
if (associated (list1%equiv)) then
list1 => list1%equiv
else
exit
end if
end do
list1%equiv => list2
end select
end subroutine ftuple_list_set_equiv
@ %def ftuple_list_set_equiv
@
<<fks regions: ftuple list: TBP>>=
procedure :: check_equiv => ftuple_list_check_equiv
<<fks regions: procedures>>=
function ftuple_list_check_equiv(list, i1, i2) result(eq)
class(ftuple_list_t), intent(in) :: list
integer, intent(in) :: i1, i2
logical :: eq
type(ftuple_list_t), pointer :: current
eq = .false.
select type (list)
type is (ftuple_list_t)
current => list%get_entry (i1)
do
if (associated (current%equiv)) then
current => current%equiv
if (current%index == i2) then
eq = .true.
exit
end if
else
exit
end if
end do
end select
end function ftuple_list_check_equiv
@ %def ftuple_list_sort
@
<<fks regions: ftuple list: TBP>>=
procedure :: to_array => ftuple_list_to_array
<<fks regions: procedures>>=
subroutine ftuple_list_to_array (ftuple_list, ftuple_array, equivalences, ordered)
class(ftuple_list_t), intent(in), target :: ftuple_list
type(ftuple_t), intent(out), dimension(:), allocatable :: ftuple_array
logical, intent(out), dimension(:,:), allocatable :: equivalences
logical, intent(in) :: ordered
integer :: i_tuple, n
type(ftuple_list_t), pointer :: current => null ()
integer :: i1, i2
type(ftuple_t) :: ftuple_tmp
logical, dimension(:), allocatable :: eq_tmp
n = ftuple_list%get_n_tuples ()
allocate (ftuple_array (n), equivalences (n, n))
equivalences = .false.
select type (ftuple_list)
type is (ftuple_list_t)
current => ftuple_list
i_tuple = 1
do
ftuple_array(i_tuple) = current%ftuple
if (associated (current%equiv)) then
i1 = current%index
i2 = current%equiv%index
equivalences (i1, i2) = .true.
end if
if (associated (current%next)) then
current => current%next
i_tuple = i_tuple + 1
else
exit
end if
end do
end select
if (ordered) then
allocate (eq_tmp (n))
do i1 = 2, n
i2 = i1
do while (i2 > 1 .and. ftuple_compare (ftuple_array(i2 - 1), ftuple_array(i2)))
ftuple_tmp = ftuple_array(i2 - 1)
eq_tmp = equivalences(i2, :)
ftuple_array(i2 - 1) = ftuple_array(i2)
ftuple_array(i2) = ftuple_tmp
equivalences(i2 - 1, :) = equivalences(i2, :)
equivalences(i2, :) = eq_tmp
i2 = i2 - 1
end do
end do
deallocate (eq_tmp)
end if
end subroutine ftuple_list_to_array
@ %def ftuple_list_to_array
@
<<fks regions: procedures>>=
subroutine print_equivalence_matrix (ftuple_array, equivalences)
type(ftuple_t), intent(in), dimension(:) :: ftuple_array
logical, intent(in), dimension(:,:) :: equivalences
integer :: i, i1, i2
print *, 'Equivalence matrix: '
do i = 1, size (ftuple_array)
call ftuple_array(i)%get(i1,i2)
print *, 'i: ', i, '(', i1, i2, '): ', equivalences(i,:)
end do
end subroutine print_equivalence_matrix
@ %def print_equivalence_matrix
@ Class for working with the flavor specification arrays.
<<fks regions: public>>=
public :: flv_structure_t
<<fks regions: types>>=
type :: flv_structure_t
integer, dimension(:), allocatable :: flst
integer, dimension(:), allocatable :: tag
integer :: nlegs = 0
integer :: n_in = 0
logical, dimension(:), allocatable :: massive
logical, dimension(:), allocatable :: colored
real(default), dimension(:), allocatable :: charge
contains
<<fks regions: flv structure: TBP>>
end type flv_structure_t
@ %def flv_structure_t
@
Returns \texttt{true} if the two particles at position \texttt{i}
and \texttt{j} in the flavor array can originate from the same
splitting. For this purpose, the function first checks whether the splitting is
allowed at all. If this is the case, the emitter is removed from the
flavor array. If the resulting array is equivalent to the Born flavor
structure \texttt{flv\_born}, the pair is accepted as a valid
splitting. We first check whether the splitting is possible. The array
[[flv_orig]] contains all particles which share a vertex with the
particles at position [[i]] and [[j]]. If its size is equal to zero,
no splitting is possible and the subroutine is exited. Otherwise,
we loop over all possible underlying Born flavor structures and check
if any of them equals the actual underlying Born flavor structure.
For a quark emitting a gluon, [[flv_orig]] contains the PDG code of
the anti-quark. To be on the safe side, a second array is created,
which contains both the positively and negatively signed PDG
codes. Then, the origial tuple $(i,j)$ is removed from the real flavor
structure and the particles in [[flv_orig2]] are inserted.
If the resulting Born configuration is equal to the underlying Born
configuration, up to a permutation of final-state particles, the tuple
$(i,j)$ is accepted as valid.
<<fks regions: flv structure: TBP>>=
procedure :: valid_pair => flv_structure_valid_pair
<<fks regions: procedures>>=
function flv_structure_valid_pair &
(flv, i, j, flv_ref, model) result (valid)
logical :: valid
class(flv_structure_t), intent(in) :: flv
integer, intent(in) :: i,j
type(flv_structure_t), intent(in) :: flv_ref
type(model_t), intent(in) :: model
integer :: k, n_orig
type(flv_structure_t) :: flv_test
integer, dimension(:), allocatable :: flv_orig
valid = .false.
if (all ([i, j] <= flv%n_in)) return
call model%match_vertex (flv%flst(i), flv%flst(j), flv_orig)
n_orig = size (flv_orig)
if (n_orig == 0) then
return
else
do k = 1, n_orig
if (any ([i, j] <= flv%n_in)) then
flv_test = flv%insert_particle_isr (i, j, flv_orig(k))
else
flv_test = flv%insert_particle_fsr (i, j, flv_orig(k))
end if
valid = flv_ref .equiv. flv_test
call flv_test%final ()
if (valid) return
end do
end if
deallocate (flv_orig)
end function flv_structure_valid_pair
@ %def flv_structure_valid_pair
@ This function checks whether two flavor arrays are the same up to a
permutation of the final-state particles
<<fks regions: procedures>>=
function flv_structure_equivalent (flv1, flv2, with_tag) result(equiv)
logical :: equiv
type(flv_structure_t), intent(in) :: flv1, flv2
logical, intent(in) :: with_tag
type(flavor_permutation_t) :: perm
integer :: n
n = size (flv1%flst)
equiv = .true.
if (n /= size (flv2%flst)) then
call msg_fatal &
('flv_structure_equivalent: flavor arrays do not have equal lengths')
else if (flv1%n_in /= flv2%n_in) then
call msg_fatal &
('flv_structure_equivalent: flavor arrays do not have equal n_in')
else
call perm%init (flv1, flv2, flv1%n_in, flv1%nlegs, with_tag)
equiv = perm%test (flv2, flv1, with_tag)
call perm%final ()
end if
end function flv_structure_equivalent
@ %def flv_structure_equivalent
@
<<fks regions: procedures>>=
function flv_structure_equivalent_no_tag (flv1, flv2) result(equiv)
logical :: equiv
type(flv_structure_t), intent(in) :: flv1, flv2
equiv = flv_structure_equivalent (flv1, flv2, .false.)
end function flv_structure_equivalent_no_tag
function flv_structure_equivalent_with_tag (flv1, flv2) result(equiv)
logical :: equiv
type(flv_structure_t), intent(in) :: flv1, flv2
equiv = flv_structure_equivalent (flv1, flv2, .true.)
end function flv_structure_equivalent_with_tag
@ %def flv_structure_equivalent_no_tag, flv_structure_equivalent_with_tag
@
<<fks regions: procedures>>=
pure subroutine flv_structure_assign_flv (flv_out, flv_in)
type(flv_structure_t), intent(out) :: flv_out
type(flv_structure_t), intent(in) :: flv_in
flv_out%nlegs = flv_in%nlegs
flv_out%n_in = flv_in%n_in
if (allocated (flv_in%flst)) then
allocate (flv_out%flst (size (flv_in%flst)))
flv_out%flst = flv_in%flst
end if
if (allocated (flv_in%tag)) then
allocate (flv_out%tag (size (flv_in%tag)))
flv_out%tag = flv_in%tag
end if
if (allocated (flv_in%massive)) then
allocate (flv_out%massive (size (flv_in%massive)))
flv_out%massive = flv_in%massive
end if
if (allocated (flv_in%colored)) then
allocate (flv_out%colored (size (flv_in%colored)))
flv_out%colored = flv_in%colored
end if
end subroutine flv_structure_assign_flv
@ %def flv_structure_assign_flv
@
<<fks regions: procedures>>=
pure subroutine flv_structure_assign_integer (flv_out, iarray)
type(flv_structure_t), intent(out) :: flv_out
integer, intent(in), dimension(:) :: iarray
integer :: i
flv_out%nlegs = size (iarray)
allocate (flv_out%flst (flv_out%nlegs))
allocate (flv_out%tag (flv_out%nlegs))
flv_out%flst = iarray
flv_out%tag = [(i, i = 1, flv_out%nlegs)]
end subroutine flv_structure_assign_integer
@ %def flv_structure_assign_integer
@ Returs a new flavor array with the particle at position
\texttt{index} removed.
<<fks regions: flv structure: TBP>>=
procedure :: remove_particle => flv_structure_remove_particle
<<fks regions: procedures>>=
function flv_structure_remove_particle (flv, index) result(flv_new)
type(flv_structure_t) :: flv_new
class(flv_structure_t), intent(in) :: flv
integer, intent(in) :: index
integer :: n1, n2
integer :: i, removed_tag
n1 = size (flv%flst); n2 = n1 - 1
allocate (flv_new%flst (n2), flv_new%tag (n2))
flv_new%nlegs = n2
flv_new%n_in = flv%n_in
removed_tag = flv%tag(index)
if (index == 1) then
flv_new%flst(1 : n2) = flv%flst(2 : n1)
flv_new%tag(1 : n2) = flv%tag(2 : n1)
else if (index == n1) then
flv_new%flst(1 : n2) = flv%flst(1 : n2)
flv_new%tag(1 : n2) = flv%tag(1 : n2)
else
flv_new%flst(1 : index - 1) = flv%flst(1 : index - 1)
flv_new%flst(index : n2) = flv%flst(index + 1 : n1)
flv_new%tag(1 : index - 1) = flv%tag(1 : index - 1)
flv_new%tag(index : n2) = flv%tag(index + 1 : n1)
end if
do i = 1, n2
if (flv_new%tag(i) > removed_tag) &
flv_new%tag(i) = flv_new%tag(i) - 1
end do
end function flv_structure_remove_particle
@ %def flv_structure_remove_particle
@
<<fks regions: flv structure: TBP>>=
procedure :: insert_particle_fsr => flv_structure_insert_particle_fsr
<<fks regions: procedures>>=
function flv_structure_insert_particle_fsr (flv, i1, i2, flv_add) result (flv_new)
type(flv_structure_t) :: flv_new
class(flv_structure_t), intent(in) :: flv
integer, intent(in) :: i1, i2, flv_add
if (flv%flst(i1) + flv_add == 0 .or. flv%flst(i2) + flv_add == 0) then
flv_new = flv%insert_particle (i1, i2, -flv_add)
else
flv_new = flv%insert_particle (i1, i2, flv_add)
end if
end function flv_structure_insert_particle_fsr
@ %def flv_structure_insert_particle_fsr
@ For ISR, the two particles are not exchangable.
<<fks regions: flv structure: TBP>>=
procedure :: insert_particle_isr => flv_structure_insert_particle_isr
<<fks regions: procedures>>=
function flv_structure_insert_particle_isr (flv, i_in, i_out, flv_add) result (flv_new)
type(flv_structure_t) :: flv_new
class(flv_structure_t), intent(in) :: flv
integer, intent(in) :: i_in, i_out, flv_add
if (flv%flst(i_in) + flv_add == 0) then
flv_new = flv%insert_particle (i_in, i_out, -flv_add)
else
flv_new = flv%insert_particle (i_in, i_out, flv_add)
end if
end function flv_structure_insert_particle_isr
@ %def flv_structure_insert_particle_isr
@ Removes the paritcles at position i1 and i2 and inserts a new
particle at position i1.
<<fks regions: flv structure: TBP>>=
procedure :: insert_particle => flv_structure_insert_particle
<<fks regions: procedures>>=
function flv_structure_insert_particle (flv, i1, i2, particle) result (flv_new)
type(flv_structure_t) :: flv_new
class(flv_structure_t), intent(in) :: flv
integer, intent(in) :: i1, i2, particle
type(flv_structure_t) :: flv_tmp
integer :: n1, n2
integer :: new_tag
n1 = size (flv%flst); n2 = n1 - 1
allocate (flv_new%flst (n2), flv_new%tag (n2))
flv_new%nlegs = n2
flv_new%n_in = flv%n_in
new_tag = maxval(flv%tag) + 1
if (i1 < i2) then
flv_tmp = flv%remove_particle (i1)
flv_tmp = flv_tmp%remove_particle (i2 - 1)
else if(i2 < i1) then
flv_tmp = flv%remove_particle(i2)
flv_tmp = flv_tmp%remove_particle(i1 - 1)
else
call msg_fatal ("flv_structure_insert_particle: Indices are identical!")
end if
if (i1 == 1) then
flv_new%flst(1) = particle
flv_new%flst(2 : n2) = flv_tmp%flst(1 : n2 - 1)
flv_new%tag(1) = new_tag
flv_new%tag(2 : n2) = flv_tmp%tag(1 : n2 - 1)
else if (i1 == n1 .or. i1 == n2) then
flv_new%flst(1 : n2 - 1) = flv_tmp%flst(1 : n2 - 1)
flv_new%flst(n2) = particle
flv_new%tag(1 : n2 - 1) = flv_tmp%tag(1 : n2 - 1)
flv_new%tag(n2) = new_tag
else
flv_new%flst(1 : i1 - 1) = flv_tmp%flst(1 : i1 - 1)
flv_new%flst(i1) = particle
flv_new%flst(i1 + 1 : n2) = flv_tmp%flst(i1 : n2 - 1)
flv_new%tag(1 : i1 - 1) = flv_tmp%tag(1 : i1 - 1)
flv_new%tag(i1) = new_tag
flv_new%tag(i1 + 1 : n2) = flv_tmp%tag(i1 : n2 - 1)
end if
end function flv_structure_insert_particle
@ %def flv_structure_insert_particle
@ Counts the number of occurances of a particle in a
flavor array
<<fks regions: flv structure: TBP>>=
procedure :: count_particle => flv_structure_count_particle
<<fks regions: procedures>>=
function flv_structure_count_particle (flv, part) result (n)
class(flv_structure_t), intent(in) :: flv
integer, intent(in) :: part
integer :: n
n = count (flv%flst == part)
end function flv_structure_count_particle
@ %def flv_structure_count_particle
@ Initializer for flavor structures
<<fks regions: flv structure: TBP>>=
procedure :: init => flv_structure_init
<<fks regions: procedures>>=
subroutine flv_structure_init (flv, aval, n_in, tags)
class(flv_structure_t), intent(inout) :: flv
integer, intent(in), dimension(:) :: aval
integer, intent(in) :: n_in
integer, intent(in), dimension(:), optional :: tags
integer :: i, n
n = size (aval)
allocate (flv%flst (n), flv%tag (n))
flv%flst = aval
if (present (tags)) then
flv%tag = tags
else
do i = 1, n
flv%tag(i) = i
end do
end if
flv%nlegs = n
flv%n_in = n_in
end subroutine flv_structure_init
@ %def flv_structure_init
@
<<fks regions: flv structure: TBP>>=
procedure :: write => flv_structure_write
<<fks regions: procedures>>=
subroutine flv_structure_write (flv, unit)
class(flv_structure_t), intent(in) :: flv
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, '(A)') char (flv%to_string ())
end subroutine flv_structure_write
@ %def flv_structure_write
@
<<fks regions: flv structure: TBP>>=
procedure :: to_string => flv_structure_to_string
<<fks regions: procedures>>=
function flv_structure_to_string (flv) result (flv_string)
type(string_t) :: flv_string
class(flv_structure_t), intent(in) :: flv
integer :: i, n
if (allocated (flv%flst)) then
flv_string = var_str ("[")
n = size (flv%flst)
do i = 1, n - 1
flv_string = flv_string // str (flv%flst(i)) // var_str(",")
end do
flv_string = flv_string // str (flv%flst(n)) // var_str("]")
else
flv_string = var_str ("[not allocated]")
end if
end function flv_structure_to_string
@ %def flv_structure_to_string
@ Creates the underlying Born flavor structure for a given real flavor
structure if the particle at position \texttt{emitter} is removed
<<fks regions: flv structure: TBP>>=
procedure :: create_uborn => flv_structure_create_uborn
<<fks regions: procedures>>=
function flv_structure_create_uborn (flv, emitter, nlo_correction_type) result(flv_uborn)
type(flv_structure_t) :: flv_uborn
class(flv_structure_t), intent(in) :: flv
type(string_t), intent(in) :: nlo_correction_type
integer, intent(in) :: emitter
integer n_legs
integer :: f1, f2
integer :: gauge_boson
n_legs = size(flv%flst)
allocate (flv_uborn%flst (n_legs - 1), flv_uborn%tag (n_legs - 1))
gauge_boson = determine_gauge_boson_to_be_inserted ()
if (emitter > flv%n_in) then
f1 = flv%flst(n_legs); f2 = flv%flst(n_legs - 1)
if (is_massless_vector (f1)) then
!!! Emitted particle is a gluon or photon => just remove it
flv_uborn = flv%remove_particle(n_legs)
else if (is_fermion (f1) .and. is_fermion (f2) .and. f1 + f2 == 0) then
!!! Emission type is a gauge boson splitting into two fermions
flv_uborn = flv%insert_particle(n_legs - 1, n_legs, gauge_boson)
else
call msg_error ("Create underlying Born: Unsupported splitting type.")
call msg_error (char (str (flv%flst)))
call msg_fatal ("FKS - FAIL")
end if
else if (emitter > 0) then
f1 = flv%flst(n_legs); f2 = flv%flst(emitter)
if (is_massless_vector (f1)) then
flv_uborn = flv%remove_particle(n_legs)
else if (is_fermion (f1) .and. is_massless_vector (f2)) then
flv_uborn = flv%insert_particle (emitter, n_legs, -f1)
else if (is_fermion (f1) .and. is_fermion (f2) .and. f1 == f2) then
flv_uborn = flv%insert_particle(emitter, n_legs, gauge_boson)
end if
else
flv_uborn = flv%remove_particle (n_legs)
end if
contains
integer function determine_gauge_boson_to_be_inserted ()
select case (char (nlo_correction_type))
case ("QCD")
determine_gauge_boson_to_be_inserted = GLUON
case ("QED")
determine_gauge_boson_to_be_inserted = PHOTON
case ("Full")
call msg_fatal ("NLO correction type 'Full' not yet implemented!")
case default
call msg_fatal ("Invalid NLO correction type! Valid inputs are: QCD, QED, Full (default: QCD)")
end select
end function determine_gauge_boson_to_be_inserted
end function flv_structure_create_uborn
@ %def flv_structure_create_uborn
@
<<fks regions: flv structure: TBP>>=
procedure :: init_mass_color_and_charge => flv_structure_init_mass_color_and_charge
<<fks regions: procedures>>=
subroutine flv_structure_init_mass_color_and_charge (flv, model)
class(flv_structure_t), intent(inout) :: flv
type(model_t), intent(in) :: model
integer :: i
type(flavor_t) :: flavor
allocate (flv%massive (flv%nlegs), flv%colored(flv%nlegs), flv%charge(flv%nlegs))
do i = 1, flv%nlegs
call flavor%init (flv%flst(i), model)
flv%massive(i) = flavor%get_mass () > 0
flv%colored(i) = &
is_quark (flv%flst(i)) .or. is_gluon (flv%flst(i))
if (flavor%is_antiparticle ()) then
flv%charge(i) = -flavor%get_charge ()
else
flv%charge(i) = flavor%get_charge ()
end if
end do
end subroutine flv_structure_init_mass_color_and_charge
@ %def flv_structure_init_mass_color_and_charge
@
<<fks regions: flv structure: TBP>>=
procedure :: get_last_two => flv_structure_get_last_two
<<fks regions: procedures>>=
function flv_structure_get_last_two (flv, n) result (flst_last)
integer, dimension(2) :: flst_last
class(flv_structure_t), intent(in) :: flv
integer, intent(in) :: n
flst_last = [flv%flst(n - 1), flv%flst(n)]
end function flv_structure_get_last_two
@ %def flv_structure_get_last_two
@
<<fks regions: flv structure: TBP>>=
procedure :: final => flv_structure_final
<<fks regions: procedures>>=
subroutine flv_structure_final (flv)
class(flv_structure_t), intent(inout) :: flv
if (allocated (flv%flst)) deallocate (flv%flst)
if (allocated (flv%tag)) deallocate (flv%tag)
if (allocated (flv%massive)) deallocate (flv%massive)
if (allocated (flv%colored)) deallocate (flv%colored)
if (allocated (flv%charge)) deallocate (flv%charge)
end subroutine flv_structure_final
@ %def flv_structure_final
@
<<fks regions: public>>=
public :: flavor_permutation_t
<<fks regions: types>>=
type :: flavor_permutation_t
integer, dimension(:,:), allocatable :: perms
contains
<<fks regions: flavor permutation: TBP>>
end type flavor_permutation_t
@ %def flavor_permutation_t
@
<<fks regions: flavor permutation: TBP>>=
procedure :: init => flavor_permutation_init
<<fks regions: procedures>>=
subroutine flavor_permutation_init (perm, flv_in, flv_ref, n_first, n_last, with_tag)
class(flavor_permutation_t), intent(out) :: perm
type(flv_structure_t), intent(in) :: flv_in, flv_ref
integer, intent(in) :: n_first, n_last
logical, intent(in) :: with_tag
integer :: flv1, flv2, tmp
integer :: tag1, tag2
integer :: i, j, j_min, i_perm
integer, dimension(:,:), allocatable :: perm_list_tmp
type(flv_structure_t) :: flv_copy
logical :: condition
logical, dimension(:), allocatable :: already_correct
flv_copy = flv_in
allocate (perm_list_tmp (factorial (n_last - n_first - 1), 2))
allocate (already_correct (flv_in%nlegs))
already_correct = flv_in%flst == flv_ref%flst
if (with_tag) &
already_correct = already_correct .and. (flv_in%tag == flv_ref%tag)
j_min = n_first + 1
i_perm = 0
do i = n_first + 1, n_last
flv1 = flv_ref%flst(i)
tag1 = flv_ref%tag(i)
do j = j_min, n_last
if (already_correct(i) .or. already_correct(j)) cycle
flv2 = flv_copy%flst(j)
tag2 = flv_copy%tag(j)
condition = (flv1 == flv2) .and. i /= j
if (with_tag) condition = condition .and. (tag1 == tag2)
if (condition) then
i_perm = i_perm + 1
tmp = flv_copy%flst(i)
flv_copy%flst(i) = flv2
flv_copy%flst(j) = tmp
tmp = flv_copy%tag(i)
flv_copy%tag(i) = tag2
flv_copy%tag(j) = tmp
perm_list_tmp (i_perm, 1) = i
perm_list_tmp (i_perm, 2) = j
exit
end if
end do
j_min = j_min + 1
end do
allocate (perm%perms (i_perm, 2))
perm%perms = perm_list_tmp (1 : i_perm, :)
deallocate (perm_list_tmp)
call flv_copy%final ()
end subroutine flavor_permutation_init
@ %def flavor_permutation_init
@
<<fks regions: flavor permutation: TBP>>=
procedure :: write => flavor_permutation_write
<<fks regions: procedures>>=
subroutine flavor_permutation_write (perm, unit)
class(flavor_permutation_t), intent(in) :: perm
integer, intent(in), optional :: unit
integer :: i, n, u
u = given_output_unit (unit); if (u < 0) return
write (u, "(A)") "Flavor permutation list: "
n = size (perm%perms, dim = 1)
if (n > 0) then
do i = 1, n
write (u, "(A1,I1,1X,I1,A1)", advance = "no") "[", perm%perms(i,1), perm%perms(i,2), "]"
if (i < n) write (u, "(A4)", advance = "no") " // "
end do
write (u, "(A)") ""
else
write (u, "(A)") "[Empty]"
end if
end subroutine flavor_permutation_write
@ %def flavor_permutation_write
@
<<fks regions: flavor permutation: TBP>>=
procedure :: reset => flavor_permutation_final
procedure :: final => flavor_permutation_final
<<fks regions: procedures>>=
subroutine flavor_permutation_final (perm)
class(flavor_permutation_t), intent(inout) :: perm
if (allocated (perm%perms)) deallocate (perm%perms)
end subroutine flavor_permutation_final
@ %def flavor_permutation_final
@
<<fks regions: flavor permutation: TBP>>=
generic :: apply => apply_permutation, &
apply_flavor, apply_integer, apply_ftuple
procedure :: apply_permutation => flavor_permutation_apply_permutation
procedure :: apply_flavor => flavor_permutation_apply_flavor
procedure :: apply_integer => flavor_permutation_apply_integer
procedure :: apply_ftuple => flavor_permutation_apply_ftuple
<<fks regions: procedures>>=
elemental function flavor_permutation_apply_permutation (perm_1, perm_2) &
result (perm_out)
type(flavor_permutation_t) :: perm_out
class(flavor_permutation_t), intent(in) :: perm_1
type(flavor_permutation_t), intent(in) :: perm_2
integer :: n1, n2
n1 = size (perm_1%perms, dim = 1)
n2 = size (perm_2%perms, dim = 1)
allocate (perm_out%perms (n1 + n2, 2))
perm_out%perms (1 : n1, :) = perm_1%perms
perm_out%perms (n1 + 1: n1 + n2, :) = perm_2%perms
end function flavor_permutation_apply_permutation
@ %def flavor_permutation_apply_permutation
@
<<fks regions: procedures>>=
elemental function flavor_permutation_apply_flavor (perm, flv_in, invert) &
result (flv_out)
type(flv_structure_t) :: flv_out
class(flavor_permutation_t), intent(in) :: perm
type(flv_structure_t), intent(in) :: flv_in
logical, intent(in), optional :: invert
integer :: i, i1, i2
integer :: p1, p2, incr
integer :: flv_tmp, tag_tmp
logical :: inv
inv = .false.; if (present(invert)) inv = invert
flv_out = flv_in
if (inv) then
p1 = 1
p2 = size (perm%perms, dim = 1)
incr = 1
else
p1 = size (perm%perms, dim = 1)
p2 = 1
incr = -1
end if
do i = p1, p2, incr
i1 = perm%perms(i,1)
i2 = perm%perms(i,2)
flv_tmp = flv_out%flst(i1)
tag_tmp = flv_out%tag(i1)
flv_out%flst(i1) = flv_out%flst(i2)
flv_out%flst(i2) = flv_tmp
flv_out%tag(i1) = flv_out%tag(i2)
flv_out%tag(i2) = tag_tmp
end do
end function flavor_permutation_apply_flavor
@ %def flavor_permutation_apply_flavor
@
<<fks regions: procedures>>=
elemental function flavor_permutation_apply_integer (perm, i_in) result (i_out)
integer :: i_out
class(flavor_permutation_t), intent(in) :: perm
integer, intent(in) :: i_in
integer :: i, i1, i2
i_out = i_in
do i = size (perm%perms(:,1)), 1, -1
i1 = perm%perms(i,1)
i2 = perm%perms(i,2)
if (i_out == i1) then
i_out = i2
else if (i_out == i2) then
i_out = i1
end if
end do
end function flavor_permutation_apply_integer
@ %def flavor_permutation_apply_integer
@
<<fks regions: procedures>>=
elemental function flavor_permutation_apply_ftuple (perm, f_in) result (f_out)
type(ftuple_t) :: f_out
class(flavor_permutation_t), intent(in) :: perm
type(ftuple_t), intent(in) :: f_in
integer :: i, i1, i2
f_out = f_in
do i = size (perm%perms, dim = 1), 1, -1
i1 = perm%perms(i,1)
i2 = perm%perms(i,2)
if (f_out%ireg(1) == i1) then
f_out%ireg(1) = i2
else if (f_out%ireg(1) == i2) then
f_out%ireg(1) = i1
end if
if (f_out%ireg(2) == i1) then
f_out%ireg(2) = i2
else if (f_out%ireg(2) == i2) then
f_out%ireg(2) = i1
end if
end do
if (f_out%ireg(1) > f_out%ireg(2)) f_out%ireg = f_out%ireg([2,1])
end function flavor_permutation_apply_ftuple
@ %def flavor_permutation_apply_ftuple
@
<<fks regions: flavor permutation: TBP>>=
procedure :: test => flavor_permutation_test
<<fks regions: procedures>>=
function flavor_permutation_test (perm, flv1, flv2, with_tag) result (valid)
logical :: valid
class(flavor_permutation_t), intent(in) :: perm
type(flv_structure_t), intent(in) :: flv1, flv2
logical, intent(in) :: with_tag
type(flv_structure_t) :: flv_test
flv_test = perm%apply (flv2, invert = .true.)
valid = all (flv_test%flst == flv1%flst)
if (with_tag) valid = valid .and. all (flv_test%tag == flv1%tag)
call flv_test%final ()
end function flavor_permutation_test
@ %def flavor_permutation_test
@ A singular region is a partition of phase space which is associated with
an individual emitter and, if relevant, resonance. It is associated with
an $\alpha_r$- and resonance-index, with a real flavor structure and
its underlying Born flavor structure. To compute the FKS weights, it is
relevant to know all the other particle indices which can result in a
divergenent phase space configuration, which are collected in the
[[ftuples]]-array.
Some singular regions might behave physically identical. E.g. a real
flavor structure associated with three-jet production is $[11,-11,0,2-2,0]$.
Here, there are two possible [[ftuples]] which contribute to the same
$u \rightarrow u g$ splitting, namely $(3,4)$ and $(4,6)$. The resulting
singular regions will be identical. To avoid this, one singular region
is associated with the multiplicity factor [[mult]]. When computing the
subtraction terms for each singular region, the result is then simply
multiplied by this factor.\\
The [[double_fsr]]-flag indicates whether the singular region should
also be supplied by a symmetry factor, explained below.
<<fks regions: public>>=
public :: singular_region_t
<<fks regions: types>>=
type :: singular_region_t
integer :: alr
integer :: i_res
type(flv_structure_t) :: flst_real
type(flv_structure_t) :: flst_uborn
integer :: mult
integer :: emitter
integer :: nregions
integer :: real_index
type(ftuple_t), dimension(:), allocatable :: ftuples
integer :: uborn_index
logical :: double_fsr = .false.
logical :: soft_divergence = .false.
logical :: coll_divergence = .false.
type(string_t) :: nlo_correction_type
integer, dimension(:), allocatable :: i_reg_to_i_con
logical :: pseudo_isr = .false.
logical :: sc_required = .false.
contains
<<fks regions: singular region: TBP>>
end type singular_region_t
@ %def singular_region_t
@
<<fks regions: singular region: TBP>>=
procedure :: init => singular_region_init
<<fks regions: procedures>>=
subroutine singular_region_init (sregion, alr, mult, i_res, &
flst_real, flst_uborn, flv_born, emitter, ftuples, equivalences, &
nlo_correction_type)
class(singular_region_t), intent(out) :: sregion
integer, intent(in) :: alr, mult, i_res
type(flv_structure_t), intent(in) :: flst_real
type(flv_structure_t), intent(in) :: flst_uborn
type(flv_structure_t), dimension(:), intent(in) :: flv_born
integer, intent(in) :: emitter
type(ftuple_t), intent(inout), dimension(:) :: ftuples
logical, intent(inout), dimension(:,:) :: equivalences
type(string_t), intent(in) :: nlo_correction_type
integer :: i
call debug_input_values ()
sregion%alr = alr
sregion%mult = mult
sregion%i_res = i_res
sregion%flst_real = flst_real
sregion%flst_uborn = flst_uborn
sregion%emitter = emitter
sregion%nlo_correction_type = nlo_correction_type
sregion%nregions = size (ftuples)
allocate (sregion%ftuples (sregion%nregions))
sregion%ftuples = ftuples
do i = 1, size(flv_born)
if (flv_born (i) .equiv. sregion%flst_uborn) then
sregion%uborn_index = i
exit
end if
end do
sregion%sc_required = any (sregion%flst_uborn%flst == GLUON) .or. &
any (sregion%flst_uborn%flst == PHOTON)
contains
subroutine debug_input_values()
if (debug_on) call msg_debug2 (D_SUBTRACTION, "singular_region_init")
if (debug2_active (D_SUBTRACTION)) then
print *, 'alr = ', alr
print *, 'mult = ', mult
print *, 'i_res = ', i_res
call flst_real%write ()
call flst_uborn%write ()
print *, 'emitter = ', emitter
call print_equivalence_matrix (ftuples, equivalences)
end if
end subroutine debug_input_values
end subroutine singular_region_init
@ %def singular_region_init
<<fks regions: singular region: TBP>>=
procedure :: write => singular_region_write
<<fks regions: procedures>>=
subroutine singular_region_write (sregion, unit, maxnregions)
class(singular_region_t), intent(in) :: sregion
integer, intent(in), optional :: unit
integer, intent(in), optional :: maxnregions
character(len=7), parameter :: flst_format = "(I3,A1)"
character(len=7), parameter :: ireg_space_format = "(7X,A1)"
integer :: nreal, nborn, i, u, mr
integer :: nleft, nright, nreg, nreg_diff
u = given_output_unit (unit); if (u < 0) return
mr = sregion%nregions; if (present (maxnregions)) mr = maxnregions
nreal = size (sregion%flst_real%flst)
nborn = size (sregion%flst_uborn%flst)
call write_vline (u)
write (u, '(A1)', advance = 'no') '['
do i = 1, nreal - 1
write (u, flst_format, advance = 'no') sregion%flst_real%flst(i), ','
end do
write (u, flst_format, advance = 'no') sregion%flst_real%flst(nreal), ']'
call write_vline (u)
write (u, '(I6)', advance = 'no') sregion%real_index
call write_vline (u)
write (u, '(I3)', advance = 'no') sregion%emitter
call write_vline (u)
write (u, '(I3)', advance = 'no') sregion%mult
call write_vline (u)
write (u, '(I4)', advance = 'no') sregion%nregions
call write_vline (u)
if (sregion%i_res > 0) then
write (u, '(I3)', advance = 'no') sregion%i_res
call write_vline (u)
end if
nreg = sregion%nregions
if (nreg == mr) then
nleft = 0
nright = 0
else
nreg_diff = mr - nreg
nleft = nreg_diff / 2
if (mod(nreg_diff , 2) == 0) then
nright = nleft
else
nright = nleft + 1
end if
end if
if (nleft > 0) then
do i = 1, nleft
write(u, ireg_space_format, advance='no') ' '
end do
end if
write (u, '(A)', advance = 'no') char (ftuple_string (sregion%ftuples, .false.))
call write_vline (u)
write (u,'(A1)',advance = 'no') '['
do i = 1, nborn - 1
write(u, flst_format, advance = 'no') sregion%flst_uborn%flst(i), ','
end do
write (u, flst_format, advance = 'no') sregion%flst_uborn%flst(nborn), ']'
call write_vline (u)
write (u, '(I7)', advance = 'no') sregion%uborn_index
write (u, '(A)')
end subroutine singular_region_write
@ %def singular_region_write
@
<<fks regions: singular region: TBP>>=
procedure :: write_latex => singular_region_write_latex
<<fks regions: procedures>>=
subroutine singular_region_write_latex (region, unit)
class(singular_region_t), intent(in) :: region
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(I2,A3,A,A3,I2,A3,I1,A3,I1,A3,A,A3,I2,A3,A,A3)") &
region%alr, " & ", char (region%flst_real%to_string ()), &
" & ", region%real_index, " & ", region%emitter, " & ", &
region%mult, " & ", char (ftuple_string (region%ftuples, .true.)), &
" & ", region%uborn_index, " & ", char (region%flst_uborn%to_string ()), &
" \\"
end subroutine singular_region_write_latex
@ %def singular_region_write_latex
@ In case of a $g \rightarrow gg$ or $g \rightarrow qq$ splitting, the factor
\begin{equation*}
\frac{2E_{\rm{em}}}{E_{\rm{em}} + E_{\rm{rad}}}
\end{equation*}
is multiplied to the real matrix element. This way, the symmetry of the splitting is used
and only one singular region has to be taken into account. However, the factor ensures that
there is only a soft singularity if the radiated parton becomes soft.
<<fks regions: singular region: TBP>>=
procedure :: set_splitting_info => singular_region_set_splitting_info
<<fks regions: procedures>>=
subroutine singular_region_set_splitting_info (region, n_in)
class(singular_region_t), intent(inout) :: region
integer, intent(in) :: n_in
integer :: i1, i2
integer :: reg
region%double_fsr = .false.
associate (ftuple => region%ftuples)
do reg = 1, region%nregions
call ftuple(reg)%get (i1, i2)
if (i1 /= region%emitter) then
cycle
else
region%soft_divergence = &
ftuple(reg)%splitting_type /= V_TO_FF
if (i1 == 0) then
region%coll_divergence = .not. any (region%flst_real%massive(1:n_in))
else
region%coll_divergence = .not. region%flst_real%massive(i1)
end if
if (ftuple(reg)%splitting_type == V_TO_VV) then
if (all (ftuple(reg)%ireg > n_in)) &
region%double_fsr = all (is_gluon (region%flst_real%flst(ftuple(reg)%ireg)))
exit
else if (ftuple(reg)%splitting_type == UNDEFINED_SPLITTING) then
call msg_fatal ("All splittings should be defined!")
end if
end if
end do
end associate
end subroutine singular_region_set_splitting_info
@ %def singular_region_set_splitting_info
@
<<fks regions: singular region: TBP>>=
procedure :: double_fsr_factor => singular_region_double_fsr_factor
<<fks regions: procedures>>=
function singular_region_double_fsr_factor (region, p) result (val)
class(singular_region_t), intent(in) :: region
type(vector4_t), intent(in), dimension(:) :: p
real(default) :: val
real(default) :: E_rad, E_em
if (region%double_fsr) then
E_em = energy (p(region%emitter))
E_rad = energy (p(region%flst_real%nlegs))
val = two * E_em / (E_em + E_rad)
else
val = one
end if
end function singular_region_double_fsr_factor
@ %def singular_region_double_fsr_factor
@
<<fks regions: singular region: TBP>>=
procedure :: has_soft_divergence => singular_region_has_soft_divergence
<<fks regions: procedures>>=
function singular_region_has_soft_divergence (region) result (div)
logical :: div
class(singular_region_t), intent(in) :: region
div = region%soft_divergence
end function singular_region_has_soft_divergence
@ %def singular_region_has_soft_divergence
@
<<fks regions: singular region: TBP>>=
procedure :: has_collinear_divergence => &
singular_region_has_collinear_divergence
<<fks regions: procedures>>=
function singular_region_has_collinear_divergence (region) result (div)
logical :: div
class(singular_region_t), intent(in) :: region
div = region%coll_divergence
end function singular_region_has_collinear_divergence
@ %def singular_region_has_collinear_divergence
@
<<fks regions: singular region: TBP>>=
procedure :: has_identical_ftuples => singular_region_has_identical_ftuples
<<fks regions: procedures>>=
elemental function singular_region_has_identical_ftuples (sregion) result (value)
logical :: value
class(singular_region_t), intent(in) :: sregion
integer :: alr
value = .false.
do alr = 1, sregion%nregions
value = value .or. (count (sregion%ftuples(alr) == sregion%ftuples) > 1)
end do
end function singular_region_has_identical_ftuples
@ %def singular_region_has_identical_ftuples
@
<<fks regions: interfaces>>=
interface assignment(=)
module procedure singular_region_assign
end interface
<<fks regions: procedures>>=
subroutine singular_region_assign (reg_out, reg_in)
type(singular_region_t), intent(out) :: reg_out
type(singular_region_t), intent(in) :: reg_in
reg_out%alr = reg_in%alr
reg_out%i_res = reg_in%i_res
reg_out%flst_real = reg_in%flst_real
reg_out%flst_uborn = reg_in%flst_uborn
reg_out%mult = reg_in%mult
reg_out%emitter = reg_in%emitter
reg_out%nregions = reg_in%nregions
reg_out%real_index = reg_in%real_index
reg_out%uborn_index = reg_in%uborn_index
reg_out%double_fsr = reg_in%double_fsr
reg_out%soft_divergence = reg_in%soft_divergence
reg_out%coll_divergence = reg_in%coll_divergence
reg_out%nlo_correction_type = reg_in%nlo_correction_type
if (allocated (reg_in%ftuples)) then
allocate (reg_out%ftuples (size (reg_in%ftuples)))
reg_out%ftuples = reg_in%ftuples
else
call msg_bug ("singular_region_assign: Trying to copy a singular region without allocated ftuples!")
end if
end subroutine singular_region_assign
@ %def singular_region_assign
@
<<fks regions: types>>=
type :: resonance_mapping_t
type(resonance_history_t), dimension(:), allocatable :: res_histories
integer, dimension(:), allocatable :: alr_to_i_res
integer, dimension(:,:), allocatable :: i_res_to_alr
type(vector4_t), dimension(:), allocatable :: p_res
contains
<<fks regions: resonance mapping: TBP>>
end type resonance_mapping_t
@ %def resonance_mapping_t
@ Testing: Init resonance mapping for $\mu \mu b b$ final state.
<<fks regions: resonance mapping: TBP>>=
procedure :: init => resonance_mapping_init
<<fks regions: procedures>>=
subroutine resonance_mapping_init (res_map, res_hist)
class(resonance_mapping_t), intent(inout) :: res_map
type(resonance_history_t), intent(in), dimension(:) :: res_hist
integer :: n_hist, i_hist1, i_hist2, n_contributors
n_contributors = 0
n_hist = size (res_hist)
allocate (res_map%res_histories (n_hist))
do i_hist1 = 1, n_hist
if (i_hist1 + 1 <= n_hist) then
do i_hist2 = i_hist1 + 1, n_hist
if (.not. (res_hist(i_hist1) .contains. res_hist(i_hist2))) &
n_contributors = n_contributors + res_hist(i_hist2)%n_resonances
end do
else
n_contributors = n_contributors + res_hist(i_hist1)%n_resonances
end if
end do
allocate (res_map%p_res (n_contributors))
res_map%res_histories = res_hist
res_map%p_res = vector4_null
end subroutine resonance_mapping_init
@ %def resonance_mapping_init
@
<<fks regions: resonance mapping: TBP>>=
procedure :: set_alr_to_i_res => resonance_mapping_set_alr_to_i_res
<<fks regions: procedures>>=
subroutine resonance_mapping_set_alr_to_i_res (res_map, regions, alr_new_to_old)
class(resonance_mapping_t), intent(inout) :: res_map
type(singular_region_t), intent(in), dimension(:) :: regions
integer, intent(out), dimension(:), allocatable :: alr_new_to_old
integer :: alr, i_res
integer :: alr_new, n_alr_res
integer :: k
if (debug_on) call msg_debug (D_SUBTRACTION, "resonance_mapping_set_alr_to_i_res")
n_alr_res = 0
do alr = 1, size (regions)
do i_res = 1, size (res_map%res_histories)
if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) &
n_alr_res = n_alr_res + 1
end do
end do
allocate (res_map%alr_to_i_res (n_alr_res))
allocate (res_map%i_res_to_alr (size (res_map%res_histories), 10))
res_map%i_res_to_alr = 0
allocate (alr_new_to_old (n_alr_res))
alr_new = 1
do alr = 1, size (regions)
do i_res = 1, size (res_map%res_histories)
if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) then
res_map%alr_to_i_res (alr_new) = i_res
alr_new_to_old (alr_new) = alr
alr_new = alr_new + 1
end if
end do
end do
do i_res = 1, size (res_map%res_histories)
k = 1
do alr = 1, size (regions)
if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) then
res_map%i_res_to_alr (i_res, k) = alr
k = k + 1
end if
end do
end do
if (debug_active (D_SUBTRACTION)) then
print *, 'i_res_to_alr:'
do i_res = 1, size(res_map%i_res_to_alr, dim=1)
print *, res_map%i_res_to_alr (i_res, :)
end do
print *, 'alr_new_to_old:', alr_new_to_old
end if
end subroutine resonance_mapping_set_alr_to_i_res
@ %def resonance_mapping_set_alr_to_i_res
@
<<fks regions: resonance mapping: TBP>>=
procedure :: get_resonance_history => resonance_mapping_get_resonance_history
<<fks regions: procedures>>=
function resonance_mapping_get_resonance_history (res_map, alr) result (res_hist)
type(resonance_history_t) :: res_hist
class(resonance_mapping_t), intent(in) :: res_map
integer, intent(in) :: alr
res_hist = res_map%res_histories(res_map%alr_to_i_res (alr))
end function resonance_mapping_get_resonance_history
@ %def resonance_mapping_get_resonance_history
@
<<fks regions: resonance mapping: TBP>>=
procedure :: write => resonance_mapping_write
<<fks regions: procedures>>=
subroutine resonance_mapping_write (res_map)
class(resonance_mapping_t), intent(in) :: res_map
integer :: i_res
do i_res = 1, size (res_map%res_histories)
call res_map%res_histories(i_res)%write ()
end do
end subroutine resonance_mapping_write
@ %def resonance_mapping_write
@
<<fks regions: resonance mapping: TBP>>=
procedure :: get_resonance_value => resonance_mapping_get_resonance_value
<<fks regions: procedures>>=
function resonance_mapping_get_resonance_value (res_map, i_res, p, i_gluon) result (p_map)
real(default) :: p_map
class(resonance_mapping_t), intent(in) :: res_map
integer, intent(in) :: i_res
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in), optional :: i_gluon
p_map = res_map%res_histories(i_res)%mapping (p, i_gluon)
end function resonance_mapping_get_resonance_value
@ %def resonance_mapping_get_resonance_value
@
<<fks regions: resonance mapping: TBP>>=
procedure :: get_resonance_all => resonance_mapping_get_resonance_all
<<fks regions: procedures>>=
function resonance_mapping_get_resonance_all (res_map, alr, p, i_gluon) result (p_map)
real(default) :: p_map
class(resonance_mapping_t), intent(in) :: res_map
integer, intent(in) :: alr
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in), optional :: i_gluon
integer :: i_res
p_map = zero
do i_res = 1, size (res_map%res_histories)
associate (res => res_map%res_histories(i_res))
if (any (res_map%i_res_to_alr (i_res, :) == alr)) &
p_map = p_map + res%mapping (p, i_gluon)
end associate
end do
end function resonance_mapping_get_resonance_all
@ %def resonance_mapping_get_resonance_all
@
<<fks regions: resonance mapping: TBP>>=
procedure :: get_weight => resonance_mapping_get_weight
<<fks regions: procedures>>=
function resonance_mapping_get_weight (res_map, alr, p) result (pfr)
real(default) :: pfr
class(resonance_mapping_t), intent(in) :: res_map
integer, intent(in) :: alr
type(vector4_t), intent(in), dimension(:) :: p
real(default) :: sumpfr
integer :: i_res
sumpfr = zero
do i_res = 1, size (res_map%res_histories)
sumpfr = sumpfr + res_map%get_resonance_value (i_res, p)
end do
pfr = res_map%get_resonance_value (res_map%alr_to_i_res (alr), p) / sumpfr
end function resonance_mapping_get_weight
@ %def resonance_mapping_get_weight
@
<<fks regions: resonance mapping: TBP>>=
procedure :: get_resonance_alr => resonance_mapping_get_resonance_alr
<<fks regions: procedures>>=
function resonance_mapping_get_resonance_alr (res_map, alr, p, i_gluon) result (p_map)
real(default) :: p_map
class(resonance_mapping_t), intent(in) :: res_map
integer, intent(in) :: alr
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in), optional :: i_gluon
integer :: i_res
i_res = res_map%alr_to_i_res (alr)
p_map = res_map%res_histories(i_res)%mapping (p, i_gluon)
end function resonance_mapping_get_resonance_alr
@ %def resonance_mapping_get_resonance_alr
@
<<fks regions: interfaces>>=
interface assignment(=)
module procedure resonance_mapping_assign
end interface
<<fks regions: procedures>>=
subroutine resonance_mapping_assign (res_map_out, res_map_in)
type(resonance_mapping_t), intent(out) :: res_map_out
type(resonance_mapping_t), intent(in) :: res_map_in
if (allocated (res_map_in%res_histories)) then
allocate (res_map_out%res_histories (size (res_map_in%res_histories)))
res_map_out%res_histories = res_map_in%res_histories
end if
if (allocated (res_map_in%alr_to_i_res)) then
allocate (res_map_out%alr_to_i_res (size (res_map_in%alr_to_i_res)))
res_map_out%alr_to_i_res = res_map_in%alr_to_i_res
end if
if (allocated (res_map_in%i_res_to_alr)) then
allocate (res_map_out%i_res_to_alr &
(size (res_map_in%i_res_to_alr, 1), size (res_map_in%i_res_to_alr, 2)))
res_map_out%i_res_to_alr = res_map_in%i_res_to_alr
end if
if (allocated (res_map_in%p_res)) then
allocate (res_map_out%p_res (size (res_map_in%p_res)))
res_map_out%p_res = res_map_in%p_res
end if
end subroutine resonance_mapping_assign
@ %def resonance_mapping_assign
@ Every FKS mapping should store the $\sum_\alpha d_{ij}^{-1}$ and
$\sum_\alpha d_{ij,\rm{soft}}^{-1}$.
Also we keep the option open to use a normlization factor, which ensures
$\sum_\alpha S_\alpha = 1$.
<<fks regions: types>>=
type, abstract :: fks_mapping_t
real(default) :: sumdij
real(default) :: sumdij_soft
logical :: pseudo_isr = .false.
real(default) :: normalization_factor = one
contains
<<fks regions: fks mapping: TBP>>
end type fks_mapping_t
@ %def fks_mapping_t
@
<<fks regions: public>>=
public :: fks_mapping_default_t
<<fks regions: types>>=
type, extends (fks_mapping_t) :: fks_mapping_default_t
real(default) :: exp_1, exp_2
integer :: n_in
contains
<<fks regions: fks mapping default: TBP>>
end type fks_mapping_default_t
@ %def fks_mapping_default_t
@
<<fks regions: public>>=
public :: fks_mapping_resonances_t
<<fks regions: types>>=
type, extends (fks_mapping_t) :: fks_mapping_resonances_t
real(default) :: exp_1, exp_2
type(resonance_mapping_t) :: res_map
integer :: i_con = 0
contains
<<fks regions: fks mapping resonances: TBP>>
end type fks_mapping_resonances_t
@ %def fks_mapping_resonances_t
@
<<fks regions: public>>=
public :: operator(.equiv.)
public :: operator(.equivtag.)
<<fks regions: interfaces>>=
interface operator(.equiv.)
module procedure flv_structure_equivalent_no_tag
end interface
interface operator(.equivtag.)
module procedure flv_structure_equivalent_with_tag
end interface
interface assignment(=)
module procedure flv_structure_assign_flv
module procedure flv_structure_assign_integer
end interface
@ %def operator_equiv
@
<<fks regions: public>>=
public :: region_data_t
<<fks regions: types>>=
type :: region_data_t
type(singular_region_t), dimension(:), allocatable :: regions
type(flv_structure_t), dimension(:), allocatable :: flv_born
type(flv_structure_t), dimension(:), allocatable :: flv_real
integer, dimension(:), allocatable :: emitters
integer :: n_regions = 0
integer :: n_emitters = 0
integer :: n_flv_born = 0
integer :: n_flv_real = 0
integer :: n_in = 0
integer :: n_legs_born = 0
integer :: n_legs_real = 0
integer :: n_phs = 0
class(fks_mapping_t), allocatable :: fks_mapping
integer, dimension(:), allocatable :: resonances
type(resonance_contributors_t), dimension(:), allocatable :: alr_contributors
integer, dimension(:), allocatable :: alr_to_i_contributor
integer, dimension(:), allocatable :: i_phs_to_i_con
contains
<<fks regions: reg data: TBP>>
end type region_data_t
@ %def region_data_t
@
<<fks regions: reg data: TBP>>=
procedure :: allocate_fks_mappings => region_data_allocate_fks_mappings
<<fks regions: procedures>>=
subroutine region_data_allocate_fks_mappings (reg_data, mapping_type)
class(region_data_t), intent(inout) :: reg_data
integer, intent(in) :: mapping_type
select case (mapping_type)
case (FKS_DEFAULT)
allocate (fks_mapping_default_t :: reg_data%fks_mapping)
case (FKS_RESONANCES)
allocate (fks_mapping_resonances_t :: reg_data%fks_mapping)
case default
call msg_fatal ("Init region_data: FKS mapping not implemented!")
end select
end subroutine region_data_allocate_fks_mappings
@ %def region_data_allocate_fks_mappings
@
<<fks regions: reg data: TBP>>=
procedure :: init => region_data_init
<<fks regions: procedures>>=
subroutine region_data_init (reg_data, n_in, model, flavor_born, &
flavor_real, nlo_correction_type)
class(region_data_t), intent(inout) :: reg_data
integer, intent(in) :: n_in
type(model_t), intent(in) :: model
integer, intent(in), dimension(:,:) :: flavor_born, flavor_real
type(ftuple_list_t), dimension(:), allocatable :: ftuples
integer, dimension(:), allocatable :: emitter
type(flv_structure_t), dimension(:), allocatable :: flst_alr
integer :: i
integer :: n_flv_real_before_check
type(string_t), intent(in) :: nlo_correction_type
reg_data%n_in = n_in
reg_data%n_flv_born = size (flavor_born, dim = 2)
reg_data%n_legs_born = size (flavor_born, dim = 1)
reg_data%n_legs_real = reg_data%n_legs_born + 1
n_flv_real_before_check = size (flavor_real, dim = 2)
allocate (reg_data%flv_born (reg_data%n_flv_born))
allocate (reg_data%flv_real (n_flv_real_before_check))
do i = 1, reg_data%n_flv_born
call reg_data%flv_born(i)%init (flavor_born (:, i), n_in)
end do
do i = 1, n_flv_real_before_check
call reg_data%flv_real(i)%init (flavor_real (:, i), n_in)
end do
call reg_data%find_regions (model, ftuples, emitter, flst_alr)
call reg_data%init_singular_regions (ftuples, emitter, flst_alr, nlo_correction_type)
reg_data%n_flv_real = maxval (reg_data%regions%real_index)
call reg_data%find_emitters ()
call reg_data%set_mass_color_and_charge (model)
call reg_data%set_splitting_info ()
end subroutine region_data_init
@ %def region_data_init
@
<<fks regions: reg data: TBP>>=
procedure :: init_resonance_information => region_data_init_resonance_information
<<fks regions: procedures>>=
subroutine region_data_init_resonance_information (reg_data)
class(region_data_t), intent(inout) :: reg_data
call reg_data%enlarge_singular_regions_with_resonances ()
call reg_data%find_resonances ()
end subroutine region_data_init_resonance_information
@ %def region_data_init_resonance_information
@
<<fks regions: reg data: TBP>>=
procedure :: set_resonance_mappings => region_data_set_resonance_mappings
<<fks regions: procedures>>=
subroutine region_data_set_resonance_mappings (reg_data, resonance_histories)
class(region_data_t), intent(inout) :: reg_data
type(resonance_history_t), intent(in), dimension(:) :: resonance_histories
select type (map => reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
call map%res_map%init (resonance_histories)
end select
end subroutine region_data_set_resonance_mappings
@ %def region_data_set_resonance_mappings
@
<<fks regions: reg data: TBP>>=
procedure :: setup_fks_mappings => region_data_setup_fks_mappings
<<fks regions: procedures>>=
subroutine region_data_setup_fks_mappings (reg_data, template, n_in)
class(region_data_t), intent(inout) :: reg_data
type(fks_template_t), intent(in) :: template
integer, intent(in) :: n_in
call reg_data%allocate_fks_mappings (template%mapping_type)
select type (map => reg_data%fks_mapping)
type is (fks_mapping_default_t)
call map%set_parameter (n_in, template%fks_dij_exp1, template%fks_dij_exp2)
end select
end subroutine region_data_setup_fks_mappings
@ %def region_data_setup_fks_mappings
@ So far, we have only created singular regions for a non-resonant case. When
resonance mappings are required, we have more singular regions, since they
must now be identified by their emitter-resonance pair index, where the emitter
must be compatible with the resonance.
<<fks regions: reg data: TBP>>=
procedure :: enlarge_singular_regions_with_resonances &
=> region_data_enlarge_singular_regions_with_resonances
<<fks regions: procedures>>=
subroutine region_data_enlarge_singular_regions_with_resonances (reg_data)
class(region_data_t), intent(inout) :: reg_data
integer :: alr
integer, dimension(:), allocatable :: alr_new_to_old
integer :: n_alr_new
type(singular_region_t), dimension(:), allocatable :: save_regions
if (debug_on) call msg_debug (D_SUBTRACTION, "region_data_enlarge_singular_regions_with_resonances")
call debug_input_values ()
select type (fks_mapping => reg_data%fks_mapping)
type is (fks_mapping_default_t)
return
type is (fks_mapping_resonances_t)
allocate (save_regions (reg_data%n_regions))
do alr = 1, reg_data%n_regions
save_regions(alr) = reg_data%regions(alr)
end do
associate (res_map => fks_mapping%res_map)
call res_map%set_alr_to_i_res (reg_data%regions, alr_new_to_old)
deallocate (reg_data%regions)
n_alr_new = size (alr_new_to_old)
reg_data%n_regions = n_alr_new
allocate (reg_data%regions (n_alr_new))
do alr = 1, n_alr_new
reg_data%regions(alr) = save_regions(alr_new_to_old (alr))
reg_data%regions(alr)%i_res = res_map%alr_to_i_res (alr)
end do
end associate
end select
contains
subroutine debug_input_values ()
if (debug2_active (D_SUBTRACTION)) then
call reg_data%write ()
end if
end subroutine debug_input_values
end subroutine region_data_enlarge_singular_regions_with_resonances
@ %def region_data_enlarge_singular_regions_with_resonances
@
<<fks regions: reg data: TBP>>=
procedure :: set_isr_pseudo_regions => region_data_set_isr_pseudo_regions
<<fks regions: procedures>>=
subroutine region_data_set_isr_pseudo_regions (reg_data)
class(region_data_t), intent(inout) :: reg_data
integer :: alr
integer :: n_alr_new
!!! Subroutine called for threshold factorization ->
!!! Size of singular regions at this point is fixed
type(singular_region_t), dimension(2) :: save_regions
integer, dimension(4) :: alr_new_to_old
do alr = 1, reg_data%n_regions
save_regions(alr) = reg_data%regions(alr)
end do
n_alr_new = reg_data%n_regions * 2
alr_new_to_old = [1, 1, 2, 2]
deallocate (reg_data%regions)
allocate (reg_data%regions (n_alr_new))
reg_data%n_regions = n_alr_new
do alr = 1, n_alr_new
reg_data%regions(alr) = save_regions(alr_new_to_old (alr))
call add_pseudo_emitters (reg_data%regions(alr))
if (mod (alr, 2) == 0) reg_data%regions(alr)%pseudo_isr = .true.
end do
contains
subroutine add_pseudo_emitters (sregion)
type(singular_region_t), intent(inout) :: sregion
type(ftuple_t), dimension(2) :: ftuples_save
integer :: alr
do alr = 1, 2
ftuples_save(alr) = sregion%ftuples(alr)
end do
deallocate (sregion%ftuples)
sregion%nregions = sregion%nregions * 2
allocate (sregion%ftuples (sregion%nregions))
do alr = 1, sregion%nregions
sregion%ftuples(alr) = ftuples_save (alr_new_to_old(alr))
if (mod (alr, 2) == 0) sregion%ftuples(alr)%pseudo_isr = .true.
end do
end subroutine add_pseudo_emitters
end subroutine region_data_set_isr_pseudo_regions
@ %def region_data_set_isr_pseudo_regions
@ This subroutine splits up the ftuple-list of the singular regions into interference-free
lists, i.e. lists which only contain the same emitter. This is relevant for factorized
NLO calculations. In the current implementation, it is hand-tailored for the threshold
computation, but should be generalized further in the future.
<<fks regions: reg data: TBP>>=
procedure :: split_up_interference_regions_for_threshold => &
region_data_split_up_interference_regions_for_threshold
<<fks regions: procedures>>=
subroutine region_data_split_up_interference_regions_for_threshold (reg_data)
class(region_data_t), intent(inout) :: reg_data
integer :: alr, i_ftuple
integer :: current_emitter
integer :: i1, i2
integer :: n_new_reg
type(ftuple_t), dimension(2) :: ftuples
do alr = 1, reg_data%n_regions
associate (region => reg_data%regions(alr))
current_emitter = region%emitter
n_new_reg = 0
do i_ftuple = 1, region%nregions
call region%ftuples(i_ftuple)%get (i1, i2)
if (i1 == current_emitter) then
n_new_reg = n_new_reg + 1
ftuples(n_new_reg) = region%ftuples(i_ftuple)
end if
end do
deallocate (region%ftuples)
allocate (region%ftuples(n_new_reg))
region%ftuples = ftuples (1 : n_new_reg)
region%nregions = n_new_reg
end associate
end do
reg_data%fks_mapping%normalization_factor = 0.5_default
end subroutine region_data_split_up_interference_regions_for_threshold
@ %def region_data_split_up_interference_regions_for_threshold
@
<<fks regions: reg data: TBP>>=
procedure :: set_mass_color_and_charge => region_data_set_mass_color_and_charge
<<fks regions: procedures>>=
subroutine region_data_set_mass_color_and_charge (reg_data, model)
class(region_data_t), intent(inout) :: reg_data
type(model_t), intent(in) :: model
integer :: i
do i = 1, reg_data%n_regions
associate (region => reg_data%regions(i))
call region%flst_uborn%init_mass_color_and_charge (model)
call region%flst_real%init_mass_color_and_charge (model)
end associate
end do
do i = 1, reg_data%n_flv_born
call reg_data%flv_born(i)%init_mass_color_and_charge (model)
end do
do i = 1, size (reg_data%flv_real)
call reg_data%flv_real(i)%init_mass_color_and_charge (model)
end do
end subroutine region_data_set_mass_color_and_charge
@ %def region_data_set_mass_color_and_charge
@
<<fks regions: reg data: TBP>>=
procedure :: uses_resonances => region_data_uses_resonances
<<fks regions: procedures>>=
function region_data_uses_resonances (reg_data) result (val)
logical :: val
class(region_data_t), intent(in) :: reg_data
select type (fks_mapping => reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
val = .true.
class default
val = .false.
end select
end function region_data_uses_resonances
@ %def region_data_uses_resonances
@ Creates a list containing the emitter of each singular region.
<<fks regions: reg data: TBP>>=
procedure :: get_emitter_list => region_data_get_emitter_list
<<fks regions: procedures>>=
- pure function region_data_get_emitter_list (reg_data) result(emitters)
+ pure function region_data_get_emitter_list (reg_data) result (emitters)
class(region_data_t), intent(in) :: reg_data
integer, dimension(:), allocatable :: emitters
integer :: i
allocate (emitters (reg_data%n_regions))
do i = 1, reg_data%n_regions
emitters(i) = reg_data%regions(i)%emitter
end do
end function region_data_get_emitter_list
@ %def region_data_get_emitter_list
+@ Returns the number of emitters not equal to 0 to avoid double counting
+between emitters 0, 1 and 2.
+<<fks regions: reg data: TBP>>=
+ procedure :: get_n_emitters_sc => region_data_get_n_emitters_sc
+<<fks regions: procedures>>=
+ function region_data_get_n_emitters_sc (reg_data) result (n_emitters_sc)
+ class(region_data_t), intent(in) :: reg_data
+ integer :: n_emitters_sc
+ n_emitters_sc = count (reg_data%emitters /= 0)
+ end function region_data_get_n_emitters_sc
+
+@ %def region_data_get_n_emitters_sc
@
<<fks regions: reg data: TBP>>=
procedure :: get_associated_resonances => region_data_get_associated_resonances
<<fks regions: procedures>>=
function region_data_get_associated_resonances (reg_data, emitter) result (res)
integer, dimension(:), allocatable :: res
class(region_data_t), intent(in) :: reg_data
integer, intent(in) :: emitter
integer :: alr, i
integer :: n_res
select type (fks_mapping => reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
n_res = 0
do alr = 1, reg_data%n_regions
if (reg_data%regions(alr)%emitter == emitter) &
n_res = n_res + 1
end do
if (n_res > 0) then
allocate (res (n_res))
else
return
end if
i = 1
do alr = 1, reg_data%n_regions
if (reg_data%regions(alr)%emitter == emitter) then
res (i) = fks_mapping%res_map%alr_to_i_res (alr)
i = i + 1
end if
end do
end select
end function region_data_get_associated_resonances
@ %def region_data_get_associated_resonances
@
<<fks regions: reg data: TBP>>=
procedure :: emitter_is_compatible_with_resonance => &
region_data_emitter_is_compatible_with_resonance
<<fks regions: procedures>>=
function region_data_emitter_is_compatible_with_resonance &
(reg_data, i_res, emitter) result (compatible)
logical :: compatible
class(region_data_t), intent(in) :: reg_data
integer, intent(in) :: i_res, emitter
integer :: i_res_alr, alr
compatible = .false.
select type (fks_mapping => reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
do alr = 1, reg_data%n_regions
i_res_alr = fks_mapping%res_map%alr_to_i_res (alr)
if (i_res_alr == i_res .and. reg_data%get_emitter(alr) == emitter) then
compatible = .true.
exit
end if
end do
end select
end function region_data_emitter_is_compatible_with_resonance
@ %def region_data_emitter_is_compatible_with_resonance
@
<<fks regions: reg data: TBP>>=
procedure :: emitter_is_in_resonance => region_data_emitter_is_in_resonance
<<fks regions: procedures>>=
function region_data_emitter_is_in_resonance (reg_data, i_res, emitter) result (exist)
logical :: exist
class(region_data_t), intent(in) :: reg_data
integer, intent(in) :: i_res, emitter
integer :: i
exist = .false.
select type (fks_mapping => reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
associate (res_history => fks_mapping%res_map%res_histories(i_res))
do i = 1, res_history%n_resonances
exist = exist .or. any (res_history%resonances(i)%contributors%c == emitter)
end do
end associate
end select
end function region_data_emitter_is_in_resonance
@ %def region_data_emitter_is_in_resonance
@
<<fks regions: reg data: TBP>>=
procedure :: get_contributors => region_data_get_contributors
<<fks regions: procedures>>=
subroutine region_data_get_contributors (reg_data, i_res, emitter, c, success)
class(region_data_t), intent(in) :: reg_data
integer, intent(in) :: i_res, emitter
integer, intent(inout), dimension(:), allocatable :: c
logical, intent(out) :: success
integer :: i
success = .false.
select type (fks_mapping => reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
associate (res_history => fks_mapping%res_map%res_histories (i_res))
do i = 1, res_history%n_resonances
if (any (res_history%resonances(i)%contributors%c == emitter)) then
allocate (c (size (res_history%resonances(i)%contributors%c)))
c = res_history%resonances(i)%contributors%c
success = .true.
exit
end if
end do
end associate
end select
end subroutine region_data_get_contributors
@ %def region_data_get_contributors
@
<<fks regions: reg data: TBP>>=
procedure :: get_emitter => region_data_get_emitter
<<fks regions: procedures>>=
pure function region_data_get_emitter (reg_data, alr) result (emitter)
class(region_data_t), intent(in) :: reg_data
integer, intent(in) :: alr
integer :: emitter
emitter = reg_data%regions(alr)%emitter
end function region_data_get_emitter
@ %def region_data_get_emitter
@
<<fks regions: reg data: TBP>>=
procedure :: map_real_to_born_index => region_data_map_real_to_born_index
<<fks regions: procedures>>=
function region_data_map_real_to_born_index (reg_data, real_index) result (uborn_index)
integer :: uborn_index
class(region_data_t), intent(in) :: reg_data
integer, intent(in) :: real_index
integer :: alr
uborn_index = 0
do alr = 1, size (reg_data%regions)
if (reg_data%regions(alr)%real_index == real_index) then
uborn_index = reg_data%regions(alr)%uborn_index
exit
end if
end do
end function region_data_map_real_to_born_index
@ %def region_data_map_real_to_born_index
@
<<fks regions: reg data: TBP>>=
generic :: get_flv_states_born => get_flv_states_born_single, get_flv_states_born_array
procedure :: get_flv_states_born_single => region_data_get_flv_states_born_single
procedure :: get_flv_states_born_array => region_data_get_flv_states_born_array
<<fks regions: procedures>>=
function region_data_get_flv_states_born_array (reg_data) result (flv_states)
integer, dimension(:,:), allocatable :: flv_states
class(region_data_t), intent(in) :: reg_data
integer :: i_flv
allocate (flv_states (reg_data%n_legs_born, reg_data%n_flv_born))
do i_flv = 1, reg_data%n_flv_born
flv_states (:, i_flv) = reg_data%flv_born(i_flv)%flst
end do
end function region_data_get_flv_states_born_array
function region_data_get_flv_states_born_single (reg_data, i_flv) result (flv_states)
integer, dimension(:), allocatable :: flv_states
class(region_data_t), intent(in) :: reg_data
integer, intent(in) :: i_flv
allocate (flv_states (reg_data%n_legs_born))
flv_states = reg_data%flv_born(i_flv)%flst
end function region_data_get_flv_states_born_single
@ %def region_data_get_flv_states_born
@
<<fks regions: reg data: TBP>>=
generic :: get_flv_states_real => get_flv_states_real_single, get_flv_states_real_array
procedure :: get_flv_states_real_single => region_data_get_flv_states_real_single
procedure :: get_flv_states_real_array => region_data_get_flv_states_real_array
<<fks regions: procedures>>=
function region_data_get_flv_states_real_single (reg_data, i_flv) result (flv_states)
integer, dimension(:), allocatable :: flv_states
class(region_data_t), intent(in) :: reg_data
integer, intent(in) :: i_flv
integer :: i_reg
allocate (flv_states (reg_data%n_legs_real))
do i_reg = 1, reg_data%n_regions
if (i_flv == reg_data%regions(i_reg)%real_index) then
flv_states = reg_data%regions(i_reg)%flst_real%flst
exit
end if
end do
end function region_data_get_flv_states_real_single
function region_data_get_flv_states_real_array (reg_data) result (flv_states)
integer, dimension(:,:), allocatable :: flv_states
class(region_data_t), intent(in) :: reg_data
integer :: i_flv
allocate (flv_states (reg_data%n_legs_real, reg_data%n_flv_real))
do i_flv = 1, reg_data%n_flv_real
flv_states (:, i_flv) = reg_data%get_flv_states_real (i_flv)
end do
end function region_data_get_flv_states_real_array
@ %def region_data_get_flv_states_real
@
<<fks regions: reg data: TBP>>=
procedure :: get_all_flv_states => region_data_get_all_flv_states
<<fks regions: procedures>>=
subroutine region_data_get_all_flv_states (reg_data, flv_born, flv_real)
class(region_data_t), intent(in) :: reg_data
integer, dimension(:,:), allocatable, intent(out) :: flv_born, flv_real
allocate (flv_born (reg_data%n_legs_born, reg_data%n_flv_born))
flv_born = reg_data%get_flv_states_born ()
allocate (flv_real (reg_data%n_legs_real, reg_data%n_flv_real))
flv_real = reg_data%get_flv_states_real ()
end subroutine region_data_get_all_flv_states
@ %def region_data_get_all_flv_states
@
<<fks regions: reg data: TBP>>=
procedure :: get_n_in => region_data_get_n_in
<<fks regions: procedures>>=
function region_data_get_n_in (reg_data) result (n_in)
integer :: n_in
class(region_data_t), intent(in) :: reg_data
n_in = reg_data%n_in
end function region_data_get_n_in
@ %def region_data_get_n_in
@
<<fks regions: reg data: TBP>>=
procedure :: get_n_legs_real => region_data_get_n_legs_real
<<fks regions: procedures>>=
function region_data_get_n_legs_real (reg_data) result (n_legs)
integer :: n_legs
class(region_data_t), intent(in) :: reg_data
n_legs = reg_data%n_legs_real
end function region_data_get_n_legs_real
@ %def region_data_get_n_legs_real
<<fks regions: reg data: TBP>>=
procedure :: get_n_legs_born => region_data_get_n_legs_born
<<fks regions: procedures>>=
function region_data_get_n_legs_born (reg_data) result (n_legs)
integer :: n_legs
class(region_data_t), intent(in) :: reg_data
n_legs = reg_data%n_legs_born
end function region_data_get_n_legs_born
@ %def region_data_get_n_legs_born
<<fks regions: reg data: TBP>>=
procedure :: get_n_flv_real => region_data_get_n_flv_real
<<fks regions: procedures>>=
function region_data_get_n_flv_real (reg_data) result (n_flv)
integer :: n_flv
class(region_data_t), intent(in) :: reg_data
n_flv = reg_data%n_flv_real
end function region_data_get_n_flv_real
@ %def region_data_get_n_flv_real
<<fks regions: reg data: TBP>>=
procedure :: get_n_flv_born => region_data_get_n_flv_born
<<fks regions: procedures>>=
function region_data_get_n_flv_born (reg_data) result (n_flv)
integer :: n_flv
class(region_data_t), intent(in) :: reg_data
n_flv = reg_data%n_flv_born
end function region_data_get_n_flv_born
@ %def region_data_get_n_flv_born
@ Returns $S_i = \frac{1}{\mathcal{D}d_i}$ or $S_{ij} =
\frac{1}{\mathcal{D}d_{ij}}$ for one particular singular region. At
this point, the flavor array should be rearranged in such a way that
the emitted particle is at the last position of
the flavor structure list.
<<fks regions: reg data: TBP>>=
generic :: get_svalue => get_svalue_last_pos, get_svalue_ij
procedure :: get_svalue_last_pos => region_data_get_svalue_last_pos
procedure :: get_svalue_ij => region_data_get_svalue_ij
<<fks regions: procedures>>=
function region_data_get_svalue_ij (reg_data, p, alr, i, j, i_res) result (sval)
class(region_data_t), intent(inout) :: reg_data
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in) :: alr, i, j
integer, intent(in) :: i_res
real(default) :: sval
associate (map => reg_data%fks_mapping)
call map%compute_sumdij (reg_data%regions(alr), p)
select type (map)
type is (fks_mapping_resonances_t)
map%i_con = reg_data%alr_to_i_contributor (alr)
end select
map%pseudo_isr = reg_data%regions(alr)%pseudo_isr
sval = map%svalue (p, i, j, i_res) * map%normalization_factor
end associate
end function region_data_get_svalue_ij
function region_data_get_svalue_last_pos (reg_data, p, alr, emitter, i_res) result (sval)
class(region_data_t), intent(inout) :: reg_data
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in) :: alr, emitter
integer, intent(in) :: i_res
real(default) :: sval
sval = reg_data%get_svalue (p, alr, emitter, reg_data%n_legs_real, i_res)
end function region_data_get_svalue_last_pos
@ %def region_data_get_svalue
@ The same as above, but for the soft limit.
<<fks regions: reg data: TBP>>=
procedure :: get_svalue_soft => region_data_get_svalue_soft
<<fks regions: procedures>>=
function region_data_get_svalue_soft &
(reg_data, p, p_soft, alr, emitter, i_res) result (sval)
class(region_data_t), intent(inout) :: reg_data
type(vector4_t), intent(in), dimension(:) :: p
type(vector4_t), intent(in) :: p_soft
integer, intent(in) :: alr, emitter, i_res
real(default) :: sval
associate (map => reg_data%fks_mapping)
call map%compute_sumdij_soft (reg_data%regions(alr), p, p_soft)
select type (map)
type is (fks_mapping_resonances_t)
map%i_con = reg_data%alr_to_i_contributor (alr)
end select
map%pseudo_isr = reg_data%regions(alr)%pseudo_isr
sval = map%svalue_soft (p, p_soft, emitter, i_res) * map%normalization_factor
end associate
end function region_data_get_svalue_soft
@ %def region_data_get_svalue_soft
@ This subroutine starts with a specification of $N$- and
$N+1$-particle configurations, [[flst_born]] and [[flst_real]], saved
in [[reg_data]]. From these, it creates a list of fundamental tuples,
a list of emitters and a list containing the $N+1$-particle
configuration, rearranged in such a way that the emitter-radiation
pair is last ([[flst_alr]]). For the $e^+ \, e^- \, \rightarrow u \,
\bar{u} \, g$- example, the generated objects are shown in table
\ref{table:ftuples and flavors}. Note that at this point, [[flst_alr]]
is arranged in such a way that the emitter can only be equal to
$n_{legs}-1$ for final-state radiation or 0, 1, or 2 for initial-state
radiation. Further, it occurs that regions can be equivalent. For
example in table \ref{table:ftuples and flavors} the regions
corresponding to \texttt{alr} = 1 and \texttt{alr} = 3 as well as
\texttt{alr} = 2 and \texttt{alr} = 4 describe the same physics and
are therefore equivalent.
@
<<fks regions: reg data: TBP>>=
procedure :: find_regions => region_data_find_regions
<<fks regions: procedures>>=
subroutine region_data_find_regions &
(reg_data, model, ftuples, emitters, flst_alr)
class(region_data_t), intent(in) :: reg_data
type(model_t), intent(in) :: model
type(ftuple_list_t), intent(out), dimension(:), allocatable :: ftuples
integer, intent(out), dimension(:), allocatable :: emitters
type(flv_structure_t), intent(out), dimension(:), allocatable :: flst_alr
type(ftuple_t) :: current_ftuple
integer, dimension(:), allocatable :: emitter_tmp
type(flv_structure_t), dimension(:), allocatable :: flst_alr_tmp
type(ftuple_list_t), dimension(:,:), allocatable :: ftuples_tmp
integer, dimension(:,:), allocatable :: ftuple_index
integer :: n_born, n_real
integer :: n_legreal
integer, parameter :: n_regions_start = 20
integer, parameter :: increment_list = 50
integer :: i_born, i_real, i_reg, i_ftuple
integer :: last_registered_i_born, last_registered_i_real
n_born = size (reg_data%flv_born)
n_real = size (reg_data%flv_real)
n_legreal = size (reg_data%flv_real(1)%flst)
allocate (ftuples_tmp (n_born,n_real))
allocate (ftuple_index (n_born,n_real))
allocate (emitter_tmp (n_regions_start))
allocate (flst_alr_tmp (n_regions_start))
i_reg = 0
ftuple_index = 0
i_ftuple = 0
last_registered_i_born = 0; last_registered_i_real = 0
do i_real = 1, n_real
do i_born = 1, n_born
call check_final_state_emissions (i_real, i_born, i_reg)
call check_initial_state_emissions (i_real, i_born, i_reg)
end do
end do
allocate (flst_alr (i_reg))
flst_alr = flst_alr_tmp(1 : i_reg)
allocate (emitters (i_reg))
emitters = emitter_tmp(1 : i_reg)
allocate (ftuples (count (ftuples_tmp%get_n_tuples () > 0)))
do i_born = 1, n_born
do i_real = 1, n_real
if (ftuples_tmp(i_born,i_real)%get_n_tuples () > 0) &
ftuples(ftuple_index(i_born,i_real)) = ftuples_tmp(i_born,i_real)
end do
end do
deallocate (flst_alr_tmp)
deallocate (emitter_tmp)
deallocate (ftuples_tmp)
deallocate (ftuple_index)
contains
subroutine extend_flv_array (flv)
type(flv_structure_t), intent(inout), dimension(:), allocatable :: flv
type(flv_structure_t), dimension(:), allocatable :: flv_store
integer :: n
n = size (flv)
allocate (flv_store (n))
flv_store = flv
deallocate (flv)
allocate (flv (n + increment_list))
flv(1:n) = flv_store
deallocate (flv_store)
end subroutine extend_flv_array
function incr_i_ftuple_if_required (i_born, i_real, i_ftuple_in) result (i_ftuple)
integer :: i_ftuple
integer, intent(in) :: i_born, i_real, i_ftuple_in
if (last_registered_i_born /= i_born .or. last_registered_i_real /= i_real) then
last_registered_i_born = i_born
last_registered_i_real = i_real
i_ftuple = i_ftuple_in + 1
else
i_ftuple = i_ftuple_in
end if
end function incr_i_ftuple_if_required
subroutine check_final_state_emissions (i_real, i_born, i_reg)
integer, intent(in) :: i_real, i_born
integer, intent(inout) :: i_reg
integer :: leg1, leg2
type(flv_structure_t) :: born_flavor
logical :: valid1, valid2
born_flavor = reg_data%flv_born(i_born)
do leg1 = reg_data%n_in + 1, n_legreal
do leg2 = leg1 + 1, n_legreal
associate (flv_real => reg_data%flv_real(i_real))
valid1 = flv_real%valid_pair(leg1, leg2, born_flavor, model)
valid2 = flv_real%valid_pair(leg2, leg1, born_flavor, model)
if (valid1 .or. valid2) then
i_reg = i_reg + 1
if (i_reg > size (flst_alr_tmp)) call extend_flv_array (flst_alr_tmp)
if(valid1) then
flst_alr_tmp(i_reg) = create_alr (flv_real, &
reg_data%n_in, leg1, leg2)
else
flst_alr_tmp(i_reg) = create_alr (flv_real, &
reg_data%n_in, leg2, leg1)
end if
call current_ftuple%set (leg1, leg2)
call current_ftuple%determine_splitting_type_fsr &
(flv_real, leg1, leg2)
i_ftuple = incr_i_ftuple_if_required (i_born, i_real, i_ftuple)
call ftuples_tmp(i_born,i_real)%append (current_ftuple)
ftuple_index(i_born,i_real) = i_ftuple
if (i_reg > size (emitter_tmp)) &
call extend_integer_array (emitter_tmp, increment_list)
emitter_tmp(i_reg) = n_legreal - 1
end if
end associate
end do
end do
end subroutine check_final_state_emissions
subroutine check_initial_state_emissions (i_real, i_born, i_reg)
integer, intent(in) :: i_real, i_born
integer, intent(inout) :: i_reg
integer :: leg, emitter
type(flv_structure_t) :: born_flavor
logical :: valid1, valid2
born_flavor = reg_data%flv_born (i_born)
do leg = reg_data%n_in + 1, n_legreal
associate (flv_real => reg_data%flv_real(i_real))
valid1 = flv_real%valid_pair(1, leg, born_flavor, model)
if (reg_data%n_in > 1) then
valid2 = flv_real%valid_pair(2, leg, born_flavor, model)
else
valid2 = .false.
end if
if (valid1 .and. valid2) then
emitter = 0
else if (valid1 .and. .not. valid2) then
emitter = 1
else if (.not. valid1 .and. valid2) then
emitter = 2
else
emitter = -1
end if
if (valid1 .or. valid2) then
i_reg = i_reg + 1
call current_ftuple%set(emitter, leg)
call current_ftuple%determine_splitting_type_isr &
(flv_real, emitter, leg)
i_ftuple = incr_i_ftuple_if_required (i_born, i_real, i_ftuple)
call ftuples_tmp(i_born,i_real)%append (current_ftuple)
ftuple_index(i_born,i_real) = i_ftuple
if (i_reg > size (emitter_tmp)) &
call extend_integer_array (emitter_tmp, increment_list)
emitter_tmp(i_reg) = emitter
if (i_reg > size (flst_alr_tmp)) call extend_flv_array (flst_alr_tmp)
flst_alr_tmp(i_reg) = &
create_alr (flv_real, reg_data%n_in, emitter, leg)
end if
end associate
end do
end subroutine check_initial_state_emissions
end subroutine region_data_find_regions
@ %def region_data_find_regions
@ Creates singular regions according to table \ref{table:singular
regions}. It scans all regions in table \ref{table:ftuples and
flavors} and records the real flavor structures. If they are
equivalent, the flavor structure is not recorded, but the multiplicity
of the present one is increased.
<<fks regions: reg data: TBP>>=
procedure :: init_singular_regions => region_data_init_singular_regions
<<fks regions: procedures>>=
subroutine region_data_init_singular_regions &
(reg_data, ftuples, emitter, flv_alr, nlo_correction_type)
class(region_data_t), intent(inout) :: reg_data
type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples
type(string_t), intent(in) :: nlo_correction_type
integer :: n_independent_flv
integer, intent(in), dimension(:) :: emitter
type(flv_structure_t), intent(in), dimension(:) :: flv_alr
type(flv_structure_t), dimension(:), allocatable :: flv_uborn, flv_alr_registered
integer, dimension(:), allocatable :: mult
integer, dimension(:), allocatable :: flst_emitter
integer :: n_regions, maxregions
integer, dimension(:), allocatable :: index
integer :: i, i_flv, n_legs
logical :: equiv, valid_fs_splitting
integer :: i_first, i_reg, i_reg_prev
integer, dimension(:), allocatable :: region_to_ftuple, alr_limits
integer, dimension(:), allocatable :: equiv_index
maxregions = size (emitter)
n_legs = flv_alr(1)%nlegs
allocate (flv_uborn (maxregions))
allocate (flv_alr_registered (maxregions))
allocate (mult (maxregions))
mult = 0
allocate (flst_emitter (maxregions))
allocate (index (maxregions))
allocate (region_to_ftuple (maxregions))
allocate (equiv_index (maxregions))
call setup_region_mappings (n_independent_flv, alr_limits, region_to_ftuple)
i_first = 1
i_reg = 1
SCAN_FLAVORS: do i_flv = 1, n_independent_flv
SCAN_FTUPLES: do i = i_first, i_first + alr_limits (i_flv) - 1
equiv = .false.
if (i == i_first) then
flv_alr_registered(i_reg) = flv_alr(i)
mult(i_reg) = mult(i_reg) + 1
flv_uborn(i_reg) = flv_alr(i)%create_uborn (emitter(i), nlo_correction_type)
flst_emitter(i_reg) = emitter(i)
index (i_reg) = region_to_index(ftuples, i)
equiv_index (i_reg) = region_to_ftuple(i)
i_reg = i_reg + 1
else
!!! Check for equivalent flavor structures
do i_reg_prev = 1, i_reg - 1
if (emitter(i) == flst_emitter(i_reg_prev) .and. emitter(i) > reg_data%n_in) then
valid_fs_splitting = check_fs_splitting (flv_alr(i)%get_last_two(n_legs), &
flv_alr_registered(i_reg_prev)%get_last_two(n_legs), &
flv_alr(i)%tag(n_legs - 1), flv_alr_registered(i_reg_prev)%tag(n_legs - 1))
if ((flv_alr(i) .equiv. flv_alr_registered(i_reg_prev)) &
.and. valid_fs_splitting) then
mult(i_reg_prev) = mult(i_reg_prev) + 1
equiv = .true.
call ftuples (region_to_index(ftuples, i))%set_equiv &
(equiv_index(i_reg_prev), region_to_ftuple(i))
exit
end if
else if (emitter(i) == flst_emitter(i_reg_prev) .and. emitter(i) <= reg_data%n_in) then
if (flv_alr(i) .equiv. flv_alr_registered(i_reg_prev)) then
mult(i_reg_prev) = mult(i_reg_prev) + 1
equiv = .true.
call ftuples (region_to_index(ftuples, i))%set_equiv &
(equiv_index(i_reg_prev), region_to_ftuple(i))
exit
end if
end if
end do
if (.not. equiv) then
flv_alr_registered(i_reg) = flv_alr(i)
mult(i_reg) = mult(i_reg) + 1
flv_uborn(i_reg) = flv_alr(i)%create_uborn (emitter(i), nlo_correction_type)
flst_emitter(i_reg) = emitter(i)
index (i_reg) = region_to_index (ftuples, i)
equiv_index (i_reg) = region_to_ftuple(i)
i_reg = i_reg + 1
end if
end if
end do SCAN_FTUPLES
i_first = i_first + alr_limits(i_flv)
end do SCAN_FLAVORS
n_regions = i_reg - 1
allocate (reg_data%regions (n_regions))
reg_data%n_regions = n_regions
call init_regions_with_permuted_flavors ()
call assign_real_indices ()
deallocate (flv_uborn)
deallocate (flv_alr_registered)
deallocate (mult)
deallocate (flst_emitter)
deallocate (index)
deallocate (region_to_ftuple)
deallocate (equiv_index)
contains
subroutine setup_region_mappings (n_independent_flv, &
alr_limits, region_to_ftuple)
integer, intent(inout) :: n_independent_flv
integer, intent(inout), dimension(:), allocatable :: alr_limits
integer, intent(inout), dimension(:), allocatable :: region_to_ftuple
integer :: i, j, i_flv
n_independent_flv = 0
do i = 1, size (ftuples)
if (ftuples(i)%get_n_tuples() > 0) &
n_independent_flv = n_independent_flv + 1
end do
allocate (alr_limits (n_independent_flv))
j = 1
do i = 1, size (ftuples)
if (ftuples(i)%get_n_tuples() > 0) then
alr_limits(j) = ftuples(i)%get_n_tuples ()
j = j + 1
end if
end do
if (.not. (sum (alr_limits) == maxregions)) &
call msg_fatal ("Too many regions!")
j = 1
do i_flv = 1, n_independent_flv
do i = 1, alr_limits(i_flv)
region_to_ftuple(j) = i
j = j + 1
end do
end do
end subroutine setup_region_mappings
subroutine check_permutation (perm, flv_perm, flv_orig, i_reg)
type(flavor_permutation_t), intent(in) :: perm
type(flv_structure_t), intent(in) :: flv_perm, flv_orig
integer, intent(in) :: i_reg
type(flv_structure_t) :: flv_test
flv_test = perm%apply (flv_orig, invert = .true.)
if (.not. all (flv_test%flst == flv_perm%flst)) then
print *, 'Fail at: ', i_reg
print *, 'Original flavor structure: ', flv_orig%flst
call perm%write ()
print *, 'Permuted flavor: ', flv_perm%flst
print *, 'Should be: ', flv_test%flst
call msg_fatal ("Permutation does not reproduce original flavor!")
end if
end subroutine check_permutation
subroutine init_regions_with_permuted_flavors ()
type(flavor_permutation_t) :: perm_list
type(ftuple_t), dimension(:), allocatable :: ftuple_array
logical, dimension(:,:), allocatable :: equivalences
integer :: i, j
do j = 1, n_regions
do i = 1, reg_data%n_flv_born
if (reg_data%flv_born (i) .equiv. flv_uborn (j)) then
call perm_list%reset ()
call perm_list%init (reg_data%flv_born(i), flv_uborn(j), &
reg_data%n_in, reg_data%n_legs_born, .true.)
flv_uborn(j) = perm_list%apply (flv_uborn(j))
flv_alr_registered(j) = perm_list%apply (flv_alr_registered(j))
flst_emitter(j) = perm_list%apply (flst_emitter(j))
end if
end do
call ftuples(index(j))%to_array (ftuple_array, equivalences, .true.)
do i = 1, size (reg_data%flv_real)
if (reg_data%flv_real(i) .equiv. flv_alr_registered(j)) then
call perm_list%reset ()
call perm_list%init (flv_alr_registered(j), reg_data%flv_real(i), &
reg_data%n_in, reg_data%n_legs_real, .false.)
if (debug_active (D_SUBTRACTION)) call check_permutation &
(perm_list, reg_data%flv_real(i), flv_alr_registered(j), j)
ftuple_array = perm_list%apply (ftuple_array)
end if
end do
call reg_data%regions(j)%init (j, mult(j), 0, flv_alr_registered(j), &
flv_uborn(j), reg_data%flv_born, flst_emitter(j), ftuple_array, &
equivalences, nlo_correction_type)
if (allocated (ftuple_array)) deallocate (ftuple_array)
if (allocated (equivalences)) deallocate (equivalences)
end do
end subroutine init_regions_with_permuted_flavors
subroutine assign_real_indices ()
type(flv_structure_t) :: current_flv_real
type(flv_structure_t), dimension(:), allocatable :: these_flv
integer :: i_real, current_uborn_index
integer :: i, j, this_i_real
allocate (these_flv (size (flv_alr_registered)))
i_real = 1
associate (regions => reg_data%regions)
do i = 1, reg_data%n_regions
do j = 1, size (these_flv)
if (.not. allocated (these_flv(j)%flst)) then
this_i_real = i_real
call these_flv(i_real)%init (flv_alr_registered(i)%flst, reg_data%n_in)
i_real = i_real + 1
exit
else if (all (these_flv(j)%flst == flv_alr_registered(i)%flst)) then
this_i_real = j
exit
end if
end do
regions(i)%real_index = this_i_real
end do
end associate
deallocate (these_flv)
end subroutine assign_real_indices
subroutine write_perm_list (perm_list)
integer, intent(in), dimension(:,:) :: perm_list
integer :: i
do i = 1, size (perm_list(:,1))
write (*,'(I1,1x,I1,A)', advance = "no" ) perm_list(i,1), perm_list(i,2), '/'
end do
print *, ''
end subroutine write_perm_list
function check_fs_splitting (flv1, flv2, tag1, tag2) result (valid)
logical :: valid
integer, intent(in), dimension(2) :: flv1, flv2
integer, intent(in) :: tag1, tag2
if (flv1(1) + flv1(2) == 0) then
valid = abs(flv1(1)) == abs(flv2(1)) .and. abs(flv1(2)) == abs(flv2(2))
else
valid = flv1(1) == flv2(1) .and. flv1(2) == flv2(2) .and. tag1 == tag2
end if
end function check_fs_splitting
end subroutine region_data_init_singular_regions
@ %def region_data_init_singular_regions
@ Create an array containing all emitters and resonances of [[region_data]].
<<fks regions: reg data: TBP>>=
procedure :: find_emitters => region_data_find_emitters
<<fks regions: procedures>>=
subroutine region_data_find_emitters (reg_data)
class(region_data_t), intent(inout) :: reg_data
integer :: alr, j, n_em, em
integer, dimension(:), allocatable :: em_count
allocate (em_count(reg_data%n_regions))
em_count = -1
n_em = 0
!!!Count the number of different emitters
do alr = 1, reg_data%n_regions
em = reg_data%regions(alr)%emitter
if (.not. any (em_count == em)) then
n_em = n_em + 1
em_count(alr) = em
end if
end do
if (n_em < 1) call msg_fatal ("region_data_find_emitters: No emitters found!")
reg_data%n_emitters = n_em
allocate (reg_data%emitters (reg_data%n_emitters))
reg_data%emitters = -1
j = 1
do alr = 1, size (reg_data%regions)
em = reg_data%regions(alr)%emitter
if (.not. any (reg_data%emitters == em)) then
reg_data%emitters(j) = em
j = j + 1
end if
end do
end subroutine region_data_find_emitters
@ %def region_data_find_emitters
@
<<fks regions: reg data: TBP>>=
procedure :: find_resonances => region_data_find_resonances
<<fks regions: procedures>>=
subroutine region_data_find_resonances (reg_data)
class(region_data_t), intent(inout) :: reg_data
integer :: alr, j, k, n_res, n_contr
integer :: res
integer, dimension(10) :: res_count
type(resonance_contributors_t), dimension(10) :: contributors_count
type(resonance_contributors_t) :: contributors
integer :: i_res, emitter
logical :: share_emitter
res_count = -1
n_res = 0; n_contr = 0
!!! Count the number of different resonances
do alr = 1, reg_data%n_regions
select type (fks_mapping => reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
res = fks_mapping%res_map%alr_to_i_res (alr)
if (.not. any (res_count == res)) then
n_res = n_res + 1
res_count(alr) = res
end if
end select
end do
if (n_res > 0) allocate (reg_data%resonances (n_res))
j = 1
select type (fks_mapping => reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
do alr = 1, size (reg_data%regions)
res = fks_mapping%res_map%alr_to_i_res (alr)
if (.not. any (reg_data%resonances == res)) then
reg_data%resonances(j) = res
j = j + 1
end if
end do
allocate (reg_data%alr_to_i_contributor (size (reg_data%regions)))
do alr = 1, size (reg_data%regions)
i_res = fks_mapping%res_map%alr_to_i_res (alr)
emitter = reg_data%regions(alr)%emitter
call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
if (.not. share_emitter) cycle
if (.not. any (contributors_count == contributors)) then
n_contr = n_contr + 1
contributors_count(alr) = contributors
end if
if (allocated (contributors%c)) deallocate (contributors%c)
end do
allocate (reg_data%alr_contributors (n_contr))
j = 1
do alr = 1, size (reg_data%regions)
i_res = fks_mapping%res_map%alr_to_i_res (alr)
emitter = reg_data%regions(alr)%emitter
call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
if (.not. share_emitter) cycle
if (.not. any (reg_data%alr_contributors == contributors)) then
reg_data%alr_contributors(j) = contributors
reg_data%alr_to_i_contributor (alr) = j
j = j + 1
else
do k = 1, size (reg_data%alr_contributors)
if (reg_data%alr_contributors(k) == contributors) exit
end do
reg_data%alr_to_i_contributor (alr) = k
end if
if (allocated (contributors%c)) deallocate (contributors%c)
end do
end select
call reg_data%extend_ftuples (n_res)
call reg_data%set_contributors ()
end subroutine region_data_find_resonances
@ %def region_data_find_resonances
@
<<fks regions: reg data: TBP>>=
procedure :: set_i_phs_to_i_con => region_data_set_i_phs_to_i_con
<<fks regions: procedures>>=
subroutine region_data_set_i_phs_to_i_con (reg_data)
class(region_data_t), intent(inout) :: reg_data
integer :: alr
integer :: i_res, emitter, i_con, i_phs, i_em
type(phs_identifier_t), dimension(:), allocatable :: phs_id_tmp
logical :: share_emitter, phs_exist
type(resonance_contributors_t) :: contributors
allocate (phs_id_tmp (reg_data%n_phs))
if (allocated (reg_data%resonances)) then
allocate (reg_data%i_phs_to_i_con (reg_data%n_phs))
do i_em = 1, size (reg_data%emitters)
emitter = reg_data%emitters(i_em)
do i_res = 1, size (reg_data%resonances)
if (reg_data%emitter_is_compatible_with_resonance (i_res, emitter)) then
alr = find_alr (emitter, i_res)
if (alr == 0) call msg_fatal ("Could not find requested alpha region!")
i_con = reg_data%alr_to_i_contributor (alr)
call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
if (.not. share_emitter) cycle
call check_for_phs_identifier &
(phs_id_tmp, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs)
if (phs_id_tmp(i_phs)%emitter < 0) then
phs_id_tmp(i_phs)%emitter = emitter
allocate (phs_id_tmp(i_phs)%contributors (size (contributors%c)))
phs_id_tmp(i_phs)%contributors = contributors%c
end if
reg_data%i_phs_to_i_con (i_phs) = i_con
end if
if (allocated (contributors%c)) deallocate (contributors%c)
end do
end do
end if
contains
function find_alr (emitter, i_res) result (alr)
integer :: alr
integer, intent(in) :: emitter, i_res
integer :: i
do i = 1, reg_data%n_regions
if (reg_data%regions(i)%emitter == emitter .and. &
reg_data%regions(i)%i_res == i_res) then
alr = i
return
end if
end do
alr = 0
end function find_alr
end subroutine region_data_set_i_phs_to_i_con
@ %def region_data_set_i_phs_to_i_con
@
<<fks regions: reg data: TBP>>=
procedure :: set_alr_to_i_phs => region_data_set_alr_to_i_phs
<<fks regions: procedures>>=
subroutine region_data_set_alr_to_i_phs (reg_data, phs_identifiers, alr_to_i_phs)
class(region_data_t), intent(inout) :: reg_data
type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
integer, intent(out), dimension(:) :: alr_to_i_phs
integer :: alr, i_phs
integer :: emitter, i_res
type(resonance_contributors_t) :: contributors
logical :: share_emitter, phs_exist
do alr = 1, reg_data%n_regions
associate (region => reg_data%regions(alr))
emitter = region%emitter
i_res = region%i_res
if (i_res /= 0) then
call reg_data%get_contributors (i_res, emitter, &
contributors%c, share_emitter)
if (.not. share_emitter) cycle
end if
if (allocated (contributors%c)) then
call check_for_phs_identifier (phs_identifiers, reg_data%n_in, &
emitter, contributors%c, phs_exist = phs_exist, i_phs = i_phs)
else
call check_for_phs_identifier (phs_identifiers, reg_data%n_in, &
emitter, phs_exist = phs_exist, i_phs = i_phs)
end if
if (.not. phs_exist) &
call msg_fatal ("phs identifiers are not set up correctly!")
alr_to_i_phs(alr) = i_phs
end associate
if (allocated (contributors%c)) deallocate (contributors%c)
end do
end subroutine region_data_set_alr_to_i_phs
@ %def region_data_set_alr_to_i_phs
@
<<fks regions: reg data: TBP>>=
procedure :: set_contributors => region_data_set_contributors
<<fks regions: procedures>>=
subroutine region_data_set_contributors (reg_data)
class(region_data_t), intent(inout) :: reg_data
integer :: alr, i_res, i_reg, i_con
integer :: i1, i2, i_em
integer, dimension(:), allocatable :: contributors
logical :: share_emitter
do alr = 1, size (reg_data%regions)
associate (sregion => reg_data%regions(alr))
allocate (sregion%i_reg_to_i_con (sregion%nregions))
do i_reg = 1, sregion%nregions
call sregion%ftuples(i_reg)%get (i1, i2)
i_em = get_emitter_index (i1, i2, reg_data%n_legs_real)
i_res = sregion%ftuples(i_reg)%i_res
call reg_data%get_contributors (i_res, i_em, contributors, share_emitter)
!!! Lookup contributor index
do i_con = 1, size (reg_data%alr_contributors)
if (all (reg_data%alr_contributors(i_con)%c == contributors)) then
sregion%i_reg_to_i_con (i_reg) = i_con
exit
end if
end do
deallocate (contributors)
end do
end associate
end do
contains
function get_emitter_index (i1, i2, n) result (i_em)
integer :: i_em
integer, intent(in) :: i1, i2, n
if (i1 == n) then
i_em = i2
else
i_em = i1
end if
end function get_emitter_index
end subroutine region_data_set_contributors
@ %def region_data_set_contributors
@ This extension of the ftuples is still too naive as it assumes that the same
resonances are possible for all ftuples
<<fks regions: reg data: TBP>>=
procedure :: extend_ftuples => region_data_extend_ftuples
<<fks regions: procedures>>=
subroutine region_data_extend_ftuples (reg_data, n_res)
class(region_data_t), intent(inout) :: reg_data
integer, intent(in) :: n_res
integer :: alr, n_reg_save
integer :: i_reg, i_res, i_em, k
type(ftuple_t), dimension(:), allocatable :: ftuple_save
integer :: n_new
do alr = 1, size (reg_data%regions)
associate (sregion => reg_data%regions(alr))
n_reg_save = sregion%nregions
allocate (ftuple_save (n_reg_save))
ftuple_save = sregion%ftuples
n_new = count_n_new_ftuples (sregion, n_res)
deallocate (sregion%ftuples)
sregion%nregions = n_new
allocate (sregion%ftuples (n_new))
k = 1
do i_res = 1, n_res
do i_reg = 1, n_reg_save
associate (ftuple_new => sregion%ftuples(k))
i_em = ftuple_save(i_reg)%ireg(1)
if (reg_data%emitter_is_in_resonance (i_res, i_em)) then
call ftuple_new%set (i_em, ftuple_save(i_reg)%ireg(2))
ftuple_new%i_res = i_res
ftuple_new%splitting_type = ftuple_save(i_reg)%splitting_type
k = k + 1
end if
end associate
end do
end do
end associate
deallocate (ftuple_save)
end do
contains
function count_n_new_ftuples (sregion, n_res) result (n_new)
integer :: n_new
type(singular_region_t), intent(in) :: sregion
integer, intent(in) :: n_res
integer :: i_reg, i_res, i_em
n_new = 0
do i_reg = 1, sregion%nregions
do i_res = 1, n_res
i_em = sregion%ftuples(i_reg)%ireg(1)
if (reg_data%emitter_is_in_resonance (i_res, i_em)) &
n_new = n_new + 1
end do
end do
end function count_n_new_ftuples
end subroutine region_data_extend_ftuples
@ %def region_data_extend_ftuples
@
<<fks regions: reg data: TBP>>=
procedure :: get_flavor_indices => region_data_get_flavor_indices
<<fks regions: procedures>>=
function region_data_get_flavor_indices (reg_data, born) result (i_flv)
integer, dimension(:), allocatable :: i_flv
class(region_data_t), intent(in) :: reg_data
logical, intent(in) :: born
allocate (i_flv (reg_data%n_regions))
if (born) then
i_flv = reg_data%regions%uborn_index
else
i_flv = reg_data%regions%real_index
end if
end function region_data_get_flavor_indices
@ %def region_data_get_flavor_indices
@
<<fks regions: reg data: TBP>>=
procedure :: get_matrix_element_index => region_data_get_matrix_element_index
<<fks regions: procedures>>=
function region_data_get_matrix_element_index (reg_data, i_reg) result (i_me)
integer :: i_me
class(region_data_t), intent(in) :: reg_data
integer, intent(in) :: i_reg
i_me = reg_data%regions(i_reg)%real_index
end function region_data_get_matrix_element_index
@ %def region_data_get_matrix_element_index
@
<<fks regions: reg data: TBP>>=
procedure :: compute_number_of_phase_spaces &
=> region_data_compute_number_of_phase_spaces
<<fks regions: procedures>>=
subroutine region_data_compute_number_of_phase_spaces (reg_data)
class(region_data_t), intent(inout) :: reg_data
integer :: i_em, i_res, i_phs
integer :: emitter
type(resonance_contributors_t) :: contributors
integer, parameter :: n_max_phs = 10
type(phs_identifier_t), dimension(n_max_phs) :: phs_id_tmp
logical :: share_emitter, phs_exist
if (allocated (reg_data%resonances)) then
reg_data%n_phs = 0
do i_em = 1, size (reg_data%emitters)
emitter = reg_data%emitters(i_em)
do i_res = 1, size (reg_data%resonances)
if (reg_data%emitter_is_compatible_with_resonance (i_res, emitter)) then
call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
if (.not. share_emitter) cycle
call check_for_phs_identifier &
(phs_id_tmp, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs)
if (.not. phs_exist) then
reg_data%n_phs = reg_data%n_phs + 1
if (reg_data%n_phs > n_max_phs) call msg_fatal &
("Buffer of phase space identifieres: Too much phase spaces!")
call phs_id_tmp(i_phs)%init (emitter, contributors%c)
end if
end if
if (allocated (contributors%c)) deallocate (contributors%c)
end do
end do
else
- reg_data%n_phs = size (remove_duplicates_from_list (reg_data%emitters))
+ reg_data%n_phs = size (remove_duplicates_from_int_array (reg_data%emitters))
end if
end subroutine region_data_compute_number_of_phase_spaces
@ %def region_data_compute_number_of_phase_spaces
@
<<fks regions: reg data: TBP>>=
procedure :: get_n_phs => region_data_get_n_phs
<<fks regions: procedures>>=
function region_data_get_n_phs (reg_data) result (n_phs)
integer :: n_phs
class(region_data_t), intent(in) :: reg_data
n_phs = reg_data%n_phs
end function region_data_get_n_phs
@ %def region_data_get_n_phs
@
<<fks regions: reg data: TBP>>=
procedure :: set_splitting_info => region_data_set_splitting_info
<<fks regions: procedures>>=
subroutine region_data_set_splitting_info (reg_data)
class(region_data_t), intent(inout) :: reg_data
integer :: alr
do alr = 1, reg_data%n_regions
call reg_data%regions(alr)%set_splitting_info (reg_data%n_in)
end do
end subroutine region_data_set_splitting_info
@ %def region_data_set_splitting_info
@
<<fks regions: reg data: TBP>>=
procedure :: init_phs_identifiers => region_data_init_phs_identifiers
<<fks regions: procedures>>=
subroutine region_data_init_phs_identifiers (reg_data, phs_id)
class(region_data_t), intent(in) :: reg_data
type(phs_identifier_t), intent(out), dimension(:), allocatable :: phs_id
integer :: i_em, i_res, i_phs
integer :: emitter
type(resonance_contributors_t) :: contributors
logical :: share_emitter, phs_exist
allocate (phs_id (reg_data%n_phs))
do i_em = 1, size (reg_data%emitters)
emitter = reg_data%emitters(i_em)
if (allocated (reg_data%resonances)) then
do i_res = 1, size (reg_data%resonances)
call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
if (.not. share_emitter) cycle
call check_for_phs_identifier &
(phs_id, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs)
if (.not. phs_exist) &
call phs_id(i_phs)%init (emitter, contributors%c)
if (allocated (contributors%c)) deallocate (contributors%c)
end do
else
call check_for_phs_identifier (phs_id, reg_data%n_in, emitter, &
phs_exist = phs_exist, i_phs = i_phs)
if (.not. phs_exist) call phs_id(i_phs)%init (emitter)
end if
end do
end subroutine region_data_init_phs_identifiers
@ %def region_data_init_phs_identifiers
@
<<fks regions: reg data: TBP>>=
procedure :: get_all_ftuples => region_data_get_all_ftuples
<<fks regions: procedures>>=
subroutine region_data_get_all_ftuples (reg_data, ftuples)
class(region_data_t), intent(in) :: reg_data
type(ftuple_t), intent(inout), dimension(:), allocatable :: ftuples
type(ftuple_t), dimension(:), allocatable :: ftuple_tmp
integer :: i, j, alr
!!! Can have at most n * (n-1) ftuples
j = 0
allocate (ftuple_tmp (reg_data%n_legs_real * (reg_data%n_legs_real - 1)))
do i = 1, reg_data%n_regions
associate (region => reg_data%regions(i))
do alr = 1, region%nregions
if (.not. any (region%ftuples(alr) == ftuple_tmp)) then
j = j + 1
ftuple_tmp(j) = region%ftuples(alr)
end if
end do
end associate
end do
allocate (ftuples (j))
ftuples = ftuple_tmp(1:j)
deallocate (ftuple_tmp)
end subroutine region_data_get_all_ftuples
@ %def region_data_get_all_ftuples
@
<<fks regions: reg data: TBP>>=
procedure :: write_to_file => region_data_write_to_file
<<fks regions: procedures>>=
subroutine region_data_write_to_file (reg_data, proc_id, latex, os_data)
class(region_data_t), intent(inout) :: reg_data
type(string_t), intent(in) :: proc_id
logical, intent(in) :: latex
type(os_data_t), intent(in) :: os_data
type(string_t) :: filename
integer :: u
integer :: status
if (latex) then
filename = proc_id // "_fks_regions.tex"
else
filename = proc_id // "_fks_regions.out"
end if
u = free_unit ()
open (u, file=char(filename), action = "write", status="replace")
if (latex) then
call reg_data%write_latex (u)
close (u)
call os_data%build_latex_file &
(proc_id // "_fks_regions", stat_out = status)
if (status /= 0) &
call msg_error (char ("Failed to compile " // filename))
else
call reg_data%write (u)
close (u)
end if
end subroutine region_data_write_to_file
@ %def region_data_write_to_file
@
<<fks regions: reg data: TBP>>=
procedure :: write_latex => region_data_write_latex
<<fks regions: procedures>>=
subroutine region_data_write_latex (reg_data, unit)
class(region_data_t), intent(in) :: reg_data
integer, intent(in), optional :: unit
integer :: i, u
u = given_output_unit (); if (present (unit)) u = unit
write (u, "(A)") "\documentclass{article}"
write (u, "(A)") "\begin{document}"
write (u, "(A)") "%FKS region data, automatically created by WHIZARD"
write (u, "(A)") "\begin{table}"
write (u, "(A)") "\begin{center}"
write (u, "(A)") "\begin{tabular} {|c|c|c|c|c|c|c|c|}"
write (u, "(A)") "\hline"
write (u, "(A)") "$\alpha_r$ & $f_r$ & $i_r$ & $\varepsilon$ & $\varsigma$ & $\mathcal{P}_{\rm{FKS}}$ & $i_b$ & $f_b$ \\"
write (u, "(A)") "\hline"
do i = 1, reg_data%n_regions
call reg_data%regions(i)%write_latex (u)
end do
write (u, "(A)") "\hline"
write (u, "(A)") "\end{tabular}"
write (u, "(A)") "\caption{List of singular regions}"
write (u, "(A)") "\begin{description}"
write (u, "(A)") "\item[$\alpha_r$] Index of the singular region"
write (u, "(A)") "\item[$f_r$] Real flavor structure"
write (u, "(A)") "\item[$i_r$] Index of the associated real flavor structure"
write (u, "(A)") "\item[$\varepsilon$] Emitter"
write (u, "(A)") "\item[$\varsigma$] Multiplicity" !!! The symbol used by 0908.4272 for multiplicities
write (u, "(A)") "\item[$\mathcal{P}_{\rm{FKS}}$] The set of singular FKS-pairs"
write (u, "(A)") "\item[$i_b$] Underlying Born index"
write (u, "(A)") "\item[$f_b$] Underlying Born flavor structure"
write (u, "(A)") "\end{description}"
write (u, "(A)") "\end{center}"
write (u, "(A)") "\end{table}"
write (u, "(A)") "\end{document}"
end subroutine region_data_write_latex
@ %def region_data_write_latex
@ Creates a table with information about all singular regions and
writes it to a file.
@ Returns the index of the real flavor structure an ftuple belongs to.
<<fks regions: reg data: TBP>>=
procedure :: write => region_data_write
<<fks regions: procedures>>=
subroutine region_data_write (reg_data, unit)
class(region_data_t), intent(in) :: reg_data
integer, intent(in), optional :: unit
integer :: j
integer :: maxnregions, i_reg_max
type(string_t) :: flst_title, ftuple_title
integer :: n_res, u
u = given_output_unit (unit); if (u < 0) return
maxnregions = 1; i_reg_max = 1
do j = 1, reg_data%n_regions
if (size (reg_data%regions(j)%ftuples) > maxnregions) then
maxnregions = reg_data%regions(j)%nregions
i_reg_max = j
end if
end do
flst_title = '(A' // flst_title_format(reg_data%n_legs_real) // ')'
ftuple_title = '(A' // ftuple_title_format() // ')'
write (u,'(A,1X,I3)') 'Total number of regions: ', size(reg_data%regions)
write (u, '(A3)', advance = 'no') 'alr'
call write_vline (u)
write (u, char (flst_title), advance = 'no') 'flst_real'
call write_vline (u)
write (u, '(A6)', advance = 'no') 'i_real'
call write_vline (u)
write (u, '(A3)', advance = 'no') 'em'
call write_vline (u)
write (u, '(A3)', advance = 'no') 'mult'
call write_vline (u)
write (u, '(A4)', advance = 'no') 'nreg'
call write_vline (u)
if (allocated (reg_data%fks_mapping)) then
select type (fks_mapping => reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
write (u, '(A3)', advance = 'no') 'res'
call write_vline (u)
end select
end if
write (u, char (ftuple_title), advance = 'no') 'ftuples'
call write_vline (u)
flst_title = '(A' // flst_title_format(reg_data%n_legs_born) // ')'
write (u, char (flst_title), advance = 'no') 'flst_born'
call write_vline (u)
write (u, '(A7)') 'i_born'
do j = 1, reg_data%n_regions
write (u, '(I3)', advance = 'no') j
call reg_data%regions(j)%write (u, maxnregions)
end do
call write_separator (u)
if (allocated (reg_data%fks_mapping)) then
select type (fks_mapping => reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
write (u, '(A)')
write (u, '(A)') "The FKS regions are combined with resonance information: "
n_res = size (fks_mapping%res_map%res_histories)
write (u, '(A,1X,I1)') "Number of QCD resonance histories: ", n_res
do j = 1, n_res
write (u, '(A,1X,I1)') "i_res = ", j
call fks_mapping%res_map%res_histories(j)%write (u)
call write_separator (u)
end do
end select
end if
contains
function flst_title_format (n) result (frmt)
integer, intent(in) :: n
type(string_t) :: frmt
character(len=2) :: frmt_char
write (frmt_char, '(I2)') 4 * n + 1
frmt = var_str (frmt_char)
end function flst_title_format
function ftuple_title_format () result (frmt)
type(string_t) :: frmt
integer :: n_ftuple_char
!!! An ftuple (x,x) consists of five characters. In the string, they
!!! are separated by maxregions - 1 commas. In total these are
!!! 5 * maxnregions + maxnregions - 1 = 6 * maxnregions - 1 characters.
!!! The {} brackets at add two additional characters.
n_ftuple_char = 6 * maxnregions + 1
!!! If there are resonances, each ftuple with a resonance adds a ";x"
!!! to the ftuple
n_ftuple_char = n_ftuple_char + 2 * count (reg_data%regions(i_reg_max)%ftuples%i_res > 0)
!!! Pseudo-ISR regions are denoted with a * at the end
n_ftuple_char = n_ftuple_char + count (reg_data%regions(i_reg_max)%ftuples%pseudo_isr)
frmt = str (n_ftuple_char)
end function ftuple_title_format
end subroutine region_data_write
@ %def region_data_write
@
<<fks regions: procedures>>=
subroutine write_vline (u)
integer, intent(in) :: u
character(len=10), parameter :: sep_format = "(1X,A2,1X)"
write (u, sep_format, advance = 'no') '||'
end subroutine write_vline
@ %def write_vline
@
<<fks regions: public>>=
public :: assignment(=)
<<fks regions: interfaces>>=
interface assignment(=)
module procedure region_data_assign
end interface
<<fks regions: procedures>>=
subroutine region_data_assign (reg_data_out, reg_data_in)
type(region_data_t), intent(out) :: reg_data_out
type(region_data_t), intent(in) :: reg_data_in
integer :: i
if (allocated (reg_data_in%regions)) then
allocate (reg_data_out%regions (size (reg_data_in%regions)))
do i = 1, size (reg_data_in%regions)
reg_data_out%regions(i) = reg_data_in%regions(i)
end do
else
call msg_warning ("Copying region data without allocated singular regions!")
end if
if (allocated (reg_data_in%flv_born)) then
allocate (reg_data_out%flv_born (size (reg_data_in%flv_born)))
do i = 1, size (reg_data_in%flv_born)
reg_data_out%flv_born(i) = reg_data_in%flv_born(i)
end do
else
call msg_warning ("Copying region data without allocated born flavor structure!")
end if
if (allocated (reg_data_in%flv_real)) then
allocate (reg_data_out%flv_real (size (reg_data_in%flv_real)))
do i = 1, size (reg_data_in%flv_real)
reg_data_out%flv_real(i) = reg_data_in%flv_real(i)
end do
else
call msg_warning ("Copying region data without allocated real flavor structure!")
end if
if (allocated (reg_data_in%emitters)) then
allocate (reg_data_out%emitters (size (reg_data_in%emitters)))
do i = 1, size (reg_data_in%emitters)
reg_data_out%emitters(i) = reg_data_in%emitters(i)
end do
else
call msg_warning ("Copying region data without allocated emitters!")
end if
reg_data_out%n_regions = reg_data_in%n_regions
reg_data_out%n_emitters = reg_data_in%n_emitters
reg_data_out%n_flv_born = reg_data_in%n_flv_born
reg_data_out%n_flv_real = reg_data_in%n_flv_real
reg_data_out%n_in = reg_data_in%n_in
reg_data_out%n_legs_born = reg_data_in%n_legs_born
reg_data_out%n_legs_real = reg_data_in%n_legs_real
if (allocated (reg_data_in%fks_mapping)) then
select type (fks_mapping_in => reg_data_in%fks_mapping)
type is (fks_mapping_default_t)
allocate (fks_mapping_default_t :: reg_data_out%fks_mapping)
select type (fks_mapping_out => reg_data_out%fks_mapping)
type is (fks_mapping_default_t)
fks_mapping_out = fks_mapping_in
end select
type is (fks_mapping_resonances_t)
allocate (fks_mapping_resonances_t :: reg_data_out%fks_mapping)
select type (fks_mapping_out => reg_data_out%fks_mapping)
type is (fks_mapping_resonances_t)
fks_mapping_out = fks_mapping_in
end select
end select
else
call msg_warning ("Copying region data without allocated FKS regions!")
end if
if (allocated (reg_data_in%resonances)) then
allocate (reg_data_out%resonances (size (reg_data_in%resonances)))
reg_data_out%resonances = reg_data_in%resonances
end if
reg_data_out%n_phs = reg_data_in%n_phs
if (allocated (reg_data_in%alr_contributors)) then
allocate (reg_data_out%alr_contributors (size (reg_data_in%alr_contributors)))
reg_data_out%alr_contributors = reg_data_in%alr_contributors
end if
if (allocated (reg_data_in%alr_to_i_contributor)) then
allocate (reg_data_out%alr_to_i_contributor &
(size (reg_data_in%alr_to_i_contributor)))
reg_data_out%alr_to_i_contributor = reg_data_in%alr_to_i_contributor
end if
end subroutine region_data_assign
@ %def region_data_assign
@ Returns the index of the real flavor structure an ftuple belogs to.
<<fks regions: procedures>>=
function region_to_index (list, i) result(index)
type(ftuple_list_t), intent(inout), dimension(:), allocatable :: list
integer, intent(in) :: i
integer :: index, nlist, j
integer, dimension(:), allocatable :: nreg
nlist = size(list)
allocate (nreg (nlist))
index = 0
do j = 1, nlist
if (j == 1) then
nreg(j) = list(j)%get_n_tuples ()
else
nreg(j) = nreg(j - 1) + list(j)%get_n_tuples ()
end if
end do
do j = 1, nlist
if (j == 1) then
if (i <= nreg(j)) then
index = j
exit
end if
else
if (i > nreg(j - 1) .and. i <= nreg(j)) then
index = j
exit
end if
end if
end do
end function region_to_index
@ %def region_to_index
@ Final state emission: Rearrange the flavor array in such a way that
the emitted particle is last and the emitter is second last. [[i1]] is
the index of the emitter, [[i2]] is the index of the emitted particle.
Initial state emission: Just put the emitted particle to the last
position.
<<fks regions: procedures>>=
function create_alr (flv1, n_in, i_em, i_rad) result(flv2)
type(flv_structure_t), intent(in) :: flv1
integer, intent(in) :: n_in
integer, intent(in) :: i_em, i_rad
type(flv_structure_t) :: flv2
integer :: n
n = size (flv1%flst)
allocate (flv2%flst (n), flv2%tag (n))
flv2%nlegs = n
flv2%n_in = n_in
if (i_em > n_in) then
flv2%flst(1 : n_in) = flv1%flst(1 : n_in)
flv2%flst(n - 1) = flv1%flst(i_em)
flv2%flst(n) = flv1%flst(i_rad)
flv2%tag(1 : n_in) = flv1%tag(1 : n_in)
flv2%tag(n - 1) = flv1%tag(i_em)
flv2%tag(n) = flv1%tag(i_rad)
call fill_remaining_flavors (n_in, .true.)
else
flv2%flst(1 : n_in) = flv1%flst(1 : n_in)
flv2%flst(n) = flv1%flst(i_rad)
flv2%tag(1 : n_in) = flv1%tag(1 : n_in)
flv2%tag(n) = flv1%tag(i_rad)
call fill_remaining_flavors (n_in, .false.)
end if
contains
@ Order remaining particles according to their original position
<<fks regions: procedures>>=
subroutine fill_remaining_flavors (n_in, final_final)
integer, intent(in) :: n_in
logical, intent(in) :: final_final
integer :: i, j
logical :: check
j = n_in + 1
do i = n_in + 1, n
if (final_final) then
check = (i /= i_em .and. i /= i_rad)
else
check = (i /= i_rad)
end if
if (check) then
flv2%flst(j) = flv1%flst(i)
flv2%tag(j) = flv1%tag(i)
j = j + 1
end if
end do
end subroutine fill_remaining_flavors
end function create_alr
@ %def create_alr
@
<<fks regions: reg data: TBP>>=
procedure :: has_pseudo_isr => region_data_has_pseudo_isr
<<fks regions: procedures>>=
function region_data_has_pseudo_isr (reg_data) result (val)
logical :: val
class(region_data_t), intent(in) :: reg_data
val = any (reg_data%regions%pseudo_isr)
end function region_data_has_pseudo_isr
@ %def region_data_has_pseudo_isr
@ Performs consistency checks on [[region_data]]. Up to now only
checks that no [[futple]] appears more than once.
<<fks regions: reg data: TBP>>=
procedure :: check_consistency => region_data_check_consistency
<<fks regions: procedures>>=
subroutine region_data_check_consistency (reg_data, fail_fatal, unit)
class(region_data_t), intent(in) :: reg_data
logical, intent(in) :: fail_fatal
integer, intent(in), optional :: unit
integer :: u
integer :: i_reg, alr
integer :: i1, f1, f2
logical :: undefined_ftuples, same_ftuple_indices, valid_splitting
logical, dimension(4) :: no_fail
u = given_output_unit(unit); if (u < 0) return
no_fail = .true.
call msg_message ("Check that no negative ftuple indices occur", unit = u)
do i_reg = 1, reg_data%n_regions
if (any (reg_data%regions(i_reg)%ftuples%has_negative_elements ())) then
!!! This error is so severe that we stop immediately
call msg_fatal ("Negative ftuple indices!")
end if
end do
call msg_message ("Success!", unit = u)
call msg_message ("Check that there is no ftuple with identical elements", unit = u)
do i_reg = 1, reg_data%n_regions
if (any (reg_data%regions(i_reg)%ftuples%has_identical_elements ())) then
!!! This error is so severe that we stop immediately
call msg_fatal ("Identical ftuple indices!")
end if
end do
call msg_message ("Success!", unit = u)
call msg_message ("Check that there are no duplicate ftuples in a region", unit = u)
do i_reg = 1, reg_data%n_regions
if (reg_data%regions(i_reg)%has_identical_ftuples ()) then
if (no_fail(1)) then
call msg_error ("FAIL: ", unit = u)
no_fail(1) = .false.
end if
write (u, '(A,1x,I3)') 'i_reg:', i_reg
end if
end do
if (no_fail(1)) call msg_message ("Success!", unit = u)
call msg_message ("Check that ftuples add up to a valid splitting", unit = u)
do i_reg = 1, reg_data%n_regions
do alr = 1, reg_data%regions(i_reg)%nregions
associate (region => reg_data%regions(i_reg))
i1 = region%ftuples(alr)%ireg(1)
if (i1 == 0) i1 = 1 !!! Gluon emission from both initial-state quarks
f1 = region%flst_real%flst(i1)
f2 = region%flst_real%flst(region%ftuples(alr)%ireg(2))
valid_splitting = f1 + f2 == 0 &
.or. (f1 == 21 .and. f2 == 21) &
.or. (is_massive_vector (f1) .and. f2 == 22) &
.or. is_fermion_vector_splitting (f1, f2)
if (.not. valid_splitting) then
if (no_fail(2)) then
call msg_error ("FAIL: ", unit = u)
no_fail(2) = .false.
end if
write (u, '(A,1x,I3)') 'i_reg:', i_reg
exit
end if
end associate
end do
end do
if (no_fail(2)) call msg_message ("Success!", unit = u)
call msg_message ("Check that at least one ftuple contains the emitter", unit = u)
do i_reg = 1, reg_data%n_regions
associate (region => reg_data%regions(i_reg))
if (.not. any (region%emitter == region%ftuples%ireg(1))) then
if (no_fail(3)) then
call msg_error ("FAIL: ", unit = u)
no_fail(3) = .false.
end if
write (u, '(A,1x,I3)') 'i_reg:', i_reg
end if
end associate
end do
if (no_fail(3)) call msg_message ("Success!", unit = u)
call msg_message ("Check that each region has at least one ftuple &
&with index n + 1", unit = u)
do i_reg = 1, reg_data%n_regions
if (.not. any (reg_data%regions(i_reg)%ftuples%ireg(2) == reg_data%n_legs_real)) then
if (no_fail(4)) then
call msg_error ("FAIL: ", unit = u)
no_fail(4) = .false.
end if
write (u, '(A,1x,I3)') 'i_reg:', i_reg
end if
end do
if (no_fail(4)) call msg_message ("Success!", unit = u)
if (.not. all (no_fail)) &
call abort_with_message ("Stop due to inconsistent region data!")
contains
subroutine abort_with_message (msg)
character(len=*), intent(in) :: msg
if (fail_fatal) then
call msg_fatal (msg)
else
call msg_error (msg, unit = u)
end if
end subroutine abort_with_message
function is_fermion_vector_splitting (pdg_1, pdg_2) result (value)
logical :: value
integer, intent(in) :: pdg_1, pdg_2
value = (is_fermion (pdg_1) .and. is_massless_vector (pdg_2)) .or. &
(is_fermion (pdg_2) .and. is_massless_vector (pdg_1))
end function
end subroutine region_data_check_consistency
@ %def region_data_check_consistency
@
<<fks regions: reg data: TBP>>=
procedure :: requires_spin_correlations => region_data_requires_spin_correlations
<<fks regions: procedures>>=
function region_data_requires_spin_correlations (reg_data) result (val)
class(region_data_t), intent(in) :: reg_data
logical :: val
integer :: alr
val = .false.
do alr = 1, reg_data%n_regions
val = reg_data%regions(alr)%sc_required
if (val) return
end do
end function region_data_requires_spin_correlations
@ %def region_data_requires_spin_correlations
@
<<fks regions: reg data: TBP>>=
procedure :: final => region_data_final
<<fks regions: procedures>>=
subroutine region_data_final (reg_data)
class(region_data_t), intent(inout) :: reg_data
if (allocated (reg_data%regions)) deallocate (reg_data%regions)
if (allocated (reg_data%flv_born)) deallocate (reg_data%flv_born)
if (allocated (reg_data%flv_real)) deallocate (reg_data%flv_real)
if (allocated (reg_data%emitters)) deallocate (reg_data%emitters)
if (allocated (reg_data%fks_mapping)) deallocate (reg_data%fks_mapping)
if (allocated (reg_data%resonances)) deallocate (reg_data%resonances)
if (allocated (reg_data%alr_contributors)) deallocate (reg_data%alr_contributors)
if (allocated (reg_data%alr_to_i_contributor)) deallocate (reg_data%alr_to_i_contributor)
end subroutine region_data_final
@ %def region_data_final
@
<<fks regions: fks mapping: TBP>>=
procedure (fks_mapping_dij), deferred :: dij
<<fks regions: interfaces>>=
abstract interface
function fks_mapping_dij (map, p, i, j, i_con) result (d)
import
real(default) :: d
class(fks_mapping_t), intent(in) :: map
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in) :: i, j
integer, intent(in), optional :: i_con
end function fks_mapping_dij
end interface
@ %def fks_mapping_dij
@
<<fks regions: fks mapping: TBP>>=
procedure (fks_mapping_compute_sumdij), deferred :: compute_sumdij
<<fks regions: interfaces>>=
abstract interface
subroutine fks_mapping_compute_sumdij (map, sregion, p)
import
class(fks_mapping_t), intent(inout) :: map
type(singular_region_t), intent(in) :: sregion
type(vector4_t), intent(in), dimension(:) :: p
end subroutine fks_mapping_compute_sumdij
end interface
@ %def fks_mapping_compute_sumdij
@
<<fks regions: fks mapping: TBP>>=
procedure (fks_mapping_svalue), deferred :: svalue
<<fks regions: interfaces>>=
abstract interface
function fks_mapping_svalue (map, p, i, j, i_res) result (value)
import
real(default) :: value
class(fks_mapping_t), intent(in) :: map
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in) :: i, j
integer, intent(in), optional :: i_res
end function fks_mapping_svalue
end interface
@ %def fks_mapping_svalue
<<fks regions: fks mapping: TBP>>=
procedure (fks_mapping_dij_soft), deferred :: dij_soft
<<fks regions: interfaces>>=
abstract interface
function fks_mapping_dij_soft (map, p_born, p_soft, em, i_con) result (d)
import
real(default) :: d
class(fks_mapping_t), intent(in) :: map
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(in) :: p_soft
integer, intent(in) :: em
integer, intent(in), optional :: i_con
end function fks_mapping_dij_soft
end interface
@ %def fks_mapping_dij_soft
@
<<fks regions: fks mapping: TBP>>=
procedure (fks_mapping_compute_sumdij_soft), deferred :: compute_sumdij_soft
<<fks regions: interfaces>>=
abstract interface
subroutine fks_mapping_compute_sumdij_soft (map, sregion, p_born, p_soft)
import
class(fks_mapping_t), intent(inout) :: map
type(singular_region_t), intent(in) :: sregion
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(in) :: p_soft
end subroutine fks_mapping_compute_sumdij_soft
end interface
@ %def fks_mapping_compute_sumdij_soft
@
<<fks regions: fks mapping: TBP>>=
procedure (fks_mapping_svalue_soft), deferred :: svalue_soft
<<fks regions: interfaces>>=
abstract interface
function fks_mapping_svalue_soft (map, p_born, p_soft, em, i_res) result (value)
import
real(default) :: value
class(fks_mapping_t), intent(in) :: map
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(in) :: p_soft
integer, intent(in) :: em
integer, intent(in), optional :: i_res
end function fks_mapping_svalue_soft
end interface
@ %def fks_mapping_svalue_soft
@
<<fks regions: fks mapping default: TBP>>=
procedure :: set_parameter => fks_mapping_default_set_parameter
<<fks regions: procedures>>=
subroutine fks_mapping_default_set_parameter (map, n_in, dij_exp1, dij_exp2)
class(fks_mapping_default_t), intent(inout) :: map
integer, intent(in) :: n_in
real(default), intent(in) :: dij_exp1, dij_exp2
map%n_in = n_in
map%exp_1 = dij_exp1
map%exp_2 = dij_exp2
end subroutine fks_mapping_default_set_parameter
@ %def fks_mapping_default_set_parameter
@ Computes the $d_{ij}$-quantities defined als follows:
\begin{align*}
d_{0i} &= \left[E_i^2\left(1-y_i\right)\right]^{p_1}\\,
d_{1i} &= \left[2E_i^2\left(1-y_i\right)\right]^{p_1}\\,
d_{2i} &= \left[2E_i^2\left(1+y_i\right)\right]^{p_1}\\,
\end{align*}
for initial state regions and
\begin{align*}
d_{ij} = \left[2(k_i \cdot k_j) \frac{E_i E_j}{(E_i+E_j)^2}\right]^{p_2}
\end{align*}
for final state regions. The exponents $p_1$ and $p_2$ can be used for
tuning the efficiency of the mapping and are set to $1$ per default.
<<fks regions: fks mapping default: TBP>>=
procedure :: dij => fks_mapping_default_dij
<<fks regions: procedures>>=
function fks_mapping_default_dij (map, p, i, j, i_con) result (d)
real(default) :: d
class(fks_mapping_default_t), intent(in) :: map
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in) :: i, j
integer, intent(in), optional :: i_con
d = zero
if (map%pseudo_isr) then
d = dij_threshold_gluon_from_top (i, j, p, map%exp_1)
else if (i > map%n_in .and. j > map%n_in) then
d = dij_fsr (p(i), p(j), map%exp_1)
else
d = dij_isr (map%n_in, i, j, p, map%exp_2)
end if
contains
function dij_fsr (p1, p2, expo) result (d_ij)
real(default) :: d_ij
type(vector4_t), intent(in) :: p1, p2
real(default), intent(in) :: expo
real(default) :: E1, E2
E1 = p1%p(0); E2 = p2%p(0)
d_ij = (two * p1 * p2 * E1 * E2 / (E1 + E2)**2)**expo
end function dij_fsr
function dij_threshold_gluon_from_top (i, j, p, expo) result (d_ij)
real(default) :: d_ij
integer, intent(in) :: i, j
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: expo
type(vector4_t) :: p_top
if (i == THR_POS_B) then
p_top = p(THR_POS_WP) + p(THR_POS_B)
else
p_top = p(THR_POS_WM) + p(THR_POS_BBAR)
end if
d_ij = dij_fsr (p_top, p(j), expo)
end function dij_threshold_gluon_from_top
function dij_isr (n_in, i, j, p, expo) result (d_ij)
real(default) :: d_ij
integer, intent(in) :: n_in, i, j
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: expo
real(default) :: E, y
select case (n_in)
case (1)
call get_emitter_variables (1, i, j, p, E, y)
d_ij = (E**2 * (one - y**2))**expo
case (2)
if ((i == 0 .and. j > 2) .or. (j == 0 .and. i > 2)) then
call get_emitter_variables (0, i, j, p, E, y)
d_ij = (E**2 * (one - y**2))**expo
else if ((i == 1 .and. j > 2) .or. (j == 1 .and. i > 2)) then
call get_emitter_variables (1, i, j, p, E, y)
d_ij = (two * E**2 * (one - y))**expo
else if ((i == 2 .and. j > 2) .or. (j == 2 .and. i > 2)) then
call get_emitter_variables (2, i, j, p, E, y)
d_ij = (two * E**2 * (one + y))**expo
end if
end select
end function dij_isr
subroutine get_emitter_variables (i_check, i, j, p, E, y)
integer, intent(in) :: i_check, i, j
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(out) :: E, y
if (j == i_check) then
E = energy (p(i))
y = polar_angle_ct (p(i))
else
E = energy (p(j))
y = polar_angle_ct(p(j))
end if
end subroutine get_emitter_variables
end function fks_mapping_default_dij
@ %def fks_mapping_default_dij
@ Computes the quantity
\begin{equation*}
\mathcal{D} = \sum_k \frac{1}{d_{0k}} + \sum_{kl} \frac{1}{d_{kl}}.
\end{equation*}
<<fks regions: fks mapping default: TBP>>=
procedure :: compute_sumdij => fks_mapping_default_compute_sumdij
<<fks regions: procedures>>=
subroutine fks_mapping_default_compute_sumdij (map, sregion, p)
class(fks_mapping_default_t), intent(inout) :: map
type(singular_region_t), intent(in) :: sregion
type(vector4_t), intent(in), dimension(:) :: p
real(default) :: d
integer :: alr, i, j
associate (ftuples => sregion%ftuples)
d = zero
do alr = 1, sregion%nregions
call ftuples(alr)%get (i, j)
map%pseudo_isr = ftuples(alr)%pseudo_isr
d = d + one / map%dij (p, i, j)
end do
end associate
map%sumdij = d
end subroutine fks_mapping_default_compute_sumdij
@ %def fks_mapping_default_compute_sumdij
@ Computes
\begin{equation*}
S_i = \frac{1}{\mathcal{D} d_{0i}}
\end{equation*}
or
\begin{equation*}
S_{ij} = \frac{1}{\mathcal{D} d_{ij}},
\end{equation*}
respectively.
<<fks regions: fks mapping default: TBP>>=
procedure :: svalue => fks_mapping_default_svalue
<<fks regions: procedures>>=
function fks_mapping_default_svalue (map, p, i, j, i_res) result (value)
real(default) :: value
class(fks_mapping_default_t), intent(in) :: map
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in) :: i, j
integer, intent(in), optional :: i_res
value = one / (map%dij (p, i, j) * map%sumdij)
end function fks_mapping_default_svalue
@ %def fks_mapping_default_svalue
@ In the soft limit, our treatment of the divergences requires a
modification of the mapping functions. Recall that there, the ratios of
the $d$-functions must approach either $1$ or $0$. This means
\begin{equation*}
\frac{d_{lm}}{d_{0m}} = \frac{(2k_l \cdot k_m) \left[E_lE_m /(E_l + E_m)^2\right]}{E_m^2 (1-y^2)} =
\overset {k_m = E_m \hat{k}} {=} \frac{E_l E_m^2}{(E_l + E_m)^2} \frac{2k_l \cdot \hat{k}}{E_m^2 (1-y^2)}
\overset {E_m \rightarrow 0}{=} \frac{2}{k_l \cdot \hat{k}}{(1-y^2)E_l},
\end{equation*}
where we have written the gluon momentum in terms of the soft momentum
$\hat{k}$. In the same limit
\begin{equation*}
\frac{d_{lm}}{d_{nm}} = \frac{k_l \cdot \hat{k}}{k_n \cdot \hat{k}} \frac{E_n}{E_l}.
\end{equation*}
From these equations we can deduce the soft limit of $d$:
\begin{align*}
d_0^{\rm{soft}} &= 1 - y^2,\\
d_1^{\rm{soft}} &= 2(1-y),\\
d_2^{\rm{soft}} &= 2(1+y),\\
d_i^{\rm{soft}} &= \frac{2 k_i \cdot \hat{k}}{E_i}.
\end{align*}
<<fks regions: fks mapping default: TBP>>=
procedure :: dij_soft => fks_mapping_default_dij_soft
<<fks regions: procedures>>=
function fks_mapping_default_dij_soft (map, p_born, p_soft, em, i_con) result (d)
real(default) :: d
class(fks_mapping_default_t), intent(in) :: map
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(in) :: p_soft
integer, intent(in) :: em
integer, intent(in), optional :: i_con
if (map%pseudo_isr) then
d = dij_soft_threshold_gluon_from_top (em, p_born, p_soft, map%exp_1)
else if (em <= map%n_in) then
d = dij_soft_isr (map%n_in, p_soft, map%exp_2)
else
d = dij_soft_fsr (p_born(em), p_soft, map%exp_1)
end if
contains
function dij_soft_threshold_gluon_from_top (em, p, p_soft, expo) result (dij_soft)
real(default) :: dij_soft
integer, intent(in) :: em
type(vector4_t), intent(in), dimension(:) :: p
type(vector4_t), intent(in) :: p_soft
real(default), intent(in) :: expo
type(vector4_t) :: p_top
if (em == THR_POS_B) then
p_top = p(THR_POS_WP) + p(THR_POS_B)
else
p_top = p(THR_POS_WM) + p(THR_POS_BBAR)
end if
dij_soft = dij_soft_fsr (p_top, p_soft, expo)
end function dij_soft_threshold_gluon_from_top
function dij_soft_fsr (p_em, p_soft, expo) result (dij_soft)
real(default) :: dij_soft
type(vector4_t), intent(in) :: p_em, p_soft
real(default), intent(in) :: expo
dij_soft = (two * p_em * p_soft / p_em%p(0))**expo
end function dij_soft_fsr
function dij_soft_isr (n_in, p_soft, expo) result (dij_soft)
real(default) :: dij_soft
integer, intent(in) :: n_in
type(vector4_t), intent(in) :: p_soft
real(default), intent(in) :: expo
real(default) :: y
y = polar_angle_ct (p_soft)
select case (n_in)
case (1)
dij_soft = one - y**2
case (2)
select case (em)
case (0)
dij_soft = one - y**2
case (1)
dij_soft = two * (one - y)
case (2)
dij_soft = two * (one + y)
case default
dij_soft = zero
call msg_fatal ("fks_mappings_default_dij_soft: n_in > 2")
end select
case default
dij_soft = zero
call msg_fatal ("fks_mappings_default_dij_soft: n_in > 2")
end select
dij_soft = dij_soft**expo
end function dij_soft_isr
end function fks_mapping_default_dij_soft
@ %def fks_mapping_default_dij_soft
@
<<fks regions: fks mapping default: TBP>>=
procedure :: compute_sumdij_soft => fks_mapping_default_compute_sumdij_soft
<<fks regions: procedures>>=
subroutine fks_mapping_default_compute_sumdij_soft (map, sregion, p_born, p_soft)
class(fks_mapping_default_t), intent(inout) :: map
type(singular_region_t), intent(in) :: sregion
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(in) :: p_soft
real(default) :: d
integer :: alr, i, j
integer :: nlegs
d = zero
nlegs = size (sregion%flst_real%flst)
associate (ftuples => sregion%ftuples)
do alr = 1, sregion%nregions
call ftuples(alr)%get (i ,j)
if (j == nlegs) then
map%pseudo_isr = ftuples(alr)%pseudo_isr
d = d + one / map%dij_soft (p_born, p_soft, i)
end if
end do
end associate
map%sumdij_soft = d
end subroutine fks_mapping_default_compute_sumdij_soft
@ %def fks_mapping_default_compute_sumdij_soft
@
<<fks regions: fks mapping default: TBP>>=
procedure :: svalue_soft => fks_mapping_default_svalue_soft
<<fks regions: procedures>>=
function fks_mapping_default_svalue_soft (map, p_born, p_soft, em, i_res) result (value)
real(default) :: value
class(fks_mapping_default_t), intent(in) :: map
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(in) :: p_soft
integer, intent(in) :: em
integer, intent(in), optional :: i_res
value = one / (map%sumdij_soft * map%dij_soft (p_born, p_soft, em))
end function fks_mapping_default_svalue_soft
@ %def fks_mapping_default_svalue_soft
@
<<fks regions: interfaces>>=
interface assignment(=)
module procedure fks_mapping_default_assign
end interface
<<fks regions: procedures>>=
subroutine fks_mapping_default_assign (fks_map_out, fks_map_in)
type(fks_mapping_default_t), intent(out) :: fks_map_out
type(fks_mapping_default_t), intent(in) :: fks_map_in
fks_map_out%exp_1 = fks_map_in%exp_1
fks_map_out%exp_2 = fks_map_in%exp_2
fks_map_out%n_in = fks_map_in%n_in
end subroutine fks_mapping_default_assign
@ %def fks_mapping_default_assign
@ The $d_{ij,k}$-functions for the resonance mapping are basically the same
as in the default case, but the kinematical values here must be evaluated
in the resonance frame of reference. The energy of parton $i$ in a given
resonance frame with momentum $p_{res}$ is
\begin{equation*}
E_i = \frac{p_i^0 \cdot p_{res}}{m_{res}}.
\end{equation*}
However, since the expressions only depend on ratios of four-momenta, we
leave out the denominator because it will cancel out anyway.
<<fks regions: fks mapping resonances: TBP>>=
procedure :: dij => fks_mapping_resonances_dij
<<fks regions: procedures>>=
function fks_mapping_resonances_dij (map, p, i, j, i_con) result (d)
real(default) :: d
class(fks_mapping_resonances_t), intent(in) :: map
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in) :: i, j
integer, intent(in), optional :: i_con
real(default) :: E1, E2
integer :: ii_con
if (present (i_con)) then
ii_con = i_con
else
call msg_fatal ("Resonance mappings require resonance index as input!")
end if
d = 0
if (i /= j) then
if (i > 2 .and. j > 2) then
associate (p_res => map%res_map%p_res (ii_con))
E1 = p(i) * p_res
E2 = p(j) * p_res
d = two * p(i) * p(j) * E1 * E2 / (E1 + E2)**2
end associate
else
call msg_fatal ("Resonance mappings are not implemented for ISR")
end if
end if
end function fks_mapping_resonances_dij
@ %def fks_mapping_resonances_dij
@ Computes
\begin{equation*}
S_\alpha = \frac{P^{f_r(\alpha)}d^{-1}(\alpha)}
{\sum_{f_r' \in T(F_r(\alpha))}P^{f_r'}\sum_{\alpha' \in Sr(f_r')}d^{-1}(\alpha)}.
\end{equation*}
<<fks regions: fks mapping resonances: TBP>>=
procedure :: compute_sumdij => fks_mapping_resonances_compute_sumdij
<<fks regions: procedures>>=
subroutine fks_mapping_resonances_compute_sumdij (map, sregion, p)
class(fks_mapping_resonances_t), intent(inout) :: map
type(singular_region_t), intent(in) :: sregion
type(vector4_t), intent(in), dimension(:) :: p
real(default) :: d, pfr
integer :: i_res, i_reg, i, j, i_con
integer :: nlegreal
nlegreal = size (p)
d = zero
do i_reg = 1, sregion%nregions
associate (ftuple => sregion%ftuples(i_reg))
call ftuple%get (i, j)
i_res = ftuple%i_res
end associate
pfr = map%res_map%get_resonance_value (i_res, p, nlegreal)
i_con = sregion%i_reg_to_i_con (i_reg)
d = d + pfr / map%dij (p, i, j, i_con)
end do
map%sumdij = d
end subroutine fks_mapping_resonances_compute_sumdij
@ %def fks_mapping_resonances_compute_sumdij
@
<<fks regions: fks mapping resonances: TBP>>=
procedure :: svalue => fks_mapping_resonances_svalue
<<fks regions: procedures>>=
function fks_mapping_resonances_svalue (map, p, i, j, i_res) result (value)
real(default) :: value
class(fks_mapping_resonances_t), intent(in) :: map
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in) :: i, j
integer, intent(in), optional :: i_res
real(default) :: pfr
integer :: i_gluon
i_gluon = size (p)
pfr = map%res_map%get_resonance_value (i_res, p, i_gluon)
value = pfr / (map%dij (p, i, j, map%i_con) * map%sumdij)
end function fks_mapping_resonances_svalue
@ %def fks_mapping_resonances_svalue
@
<<fks regions: fks mapping resonances: TBP>>=
procedure :: get_resonance_weight => fks_mapping_resonances_get_resonance_weight
<<fks regions: procedures>>=
function fks_mapping_resonances_get_resonance_weight (map, alr, p) result (pfr)
real(default) :: pfr
class(fks_mapping_resonances_t), intent(in) :: map
integer, intent(in) :: alr
type(vector4_t), intent(in), dimension(:) :: p
pfr = map%res_map%get_weight (alr, p)
end function fks_mapping_resonances_get_resonance_weight
@ %def fks_mapping_resonances_get_resonance_weight
@ As above, the soft limit of $d_{ij,k}$ must be computed in the resonance frame of
reference.
<<fks regions: fks mapping resonances: TBP>>=
procedure :: dij_soft => fks_mapping_resonances_dij_soft
<<fks regions: procedures>>=
function fks_mapping_resonances_dij_soft (map, p_born, p_soft, em, i_con) result (d)
real(default) :: d
class(fks_mapping_resonances_t), intent(in) :: map
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(in) :: p_soft
integer, intent(in) :: em
integer, intent(in), optional :: i_con
real(default) :: E1, E2
integer :: ii_con
type(vector4_t) :: pb
if (present (i_con)) then
ii_con = i_con
else
call msg_fatal ("fks_mapping_resonances requires resonance index")
end if
associate (p_res => map%res_map%p_res(ii_con))
pb = p_born(em)
E1 = pb * p_res
E2 = p_soft * p_res
d = two * pb * p_soft * E1 * E2 / E1**2
end associate
end function fks_mapping_resonances_dij_soft
@ %def fks_mapping_resonances_dij_soft
@
<<fks regions: fks mapping resonances: TBP>>=
procedure :: compute_sumdij_soft => fks_mapping_resonances_compute_sumdij_soft
<<fks regions: procedures>>=
subroutine fks_mapping_resonances_compute_sumdij_soft (map, sregion, p_born, p_soft)
class(fks_mapping_resonances_t), intent(inout) :: map
type(singular_region_t), intent(in) :: sregion
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(in) :: p_soft
real(default) :: d
real(default) :: pfr
integer :: i_res, i, j, i_reg, i_con
integer :: nlegs
d = zero
nlegs = size (sregion%flst_real%flst)
do i_reg = 1, sregion%nregions
associate (ftuple => sregion%ftuples(i_reg))
call ftuple%get(i, j)
i_res = ftuple%i_res
end associate
pfr = map%res_map%get_resonance_value (i_res, p_born)
i_con = sregion%i_reg_to_i_con (i_reg)
if (j == nlegs) d = d + pfr / map%dij_soft (p_born, p_soft, i, i_con)
end do
map%sumdij_soft = d
end subroutine fks_mapping_resonances_compute_sumdij_soft
@ %def fks_mapping_resonances_compute_sumdij_soft
@
<<fks regions: fks mapping resonances: TBP>>=
procedure :: svalue_soft => fks_mapping_resonances_svalue_soft
<<fks regions: procedures>>=
function fks_mapping_resonances_svalue_soft (map, p_born, p_soft, em, i_res) result (value)
real(default) :: value
class(fks_mapping_resonances_t), intent(in) :: map
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(in) :: p_soft
integer, intent(in) :: em
integer, intent(in), optional :: i_res
real(default) :: pfr
pfr = map%res_map%get_resonance_value (i_res, p_born)
value = pfr / (map%sumdij_soft * map%dij_soft (p_born, p_soft, em, map%i_con))
end function fks_mapping_resonances_svalue_soft
@ %def fks_mapping_resonances_svalue_soft
@
<<fks regions: fks mapping resonances: TBP>>=
procedure :: set_resonance_momentum => fks_mapping_resonances_set_resonance_momentum
<<fks regions: procedures>>=
subroutine fks_mapping_resonances_set_resonance_momentum (map, p)
class(fks_mapping_resonances_t), intent(inout) :: map
type(vector4_t), intent(in) :: p
map%res_map%p_res = p
end subroutine fks_mapping_resonances_set_resonance_momentum
@ %def fks_mapping_resonances_set_resonance_momentum
@
<<fks regions: fks mapping resonances: TBP>>=
procedure :: set_resonance_momenta => fks_mapping_resonances_set_resonance_momenta
<<fks regions: procedures>>=
subroutine fks_mapping_resonances_set_resonance_momenta (map, p)
class(fks_mapping_resonances_t), intent(inout) :: map
type(vector4_t), intent(in), dimension(:) :: p
map%res_map%p_res = p
end subroutine fks_mapping_resonances_set_resonance_momenta
@ %def fks_mapping_resonances_set_resonance_momenta
@
<<fks regions: interfaces>>=
interface assignment(=)
module procedure fks_mapping_resonances_assign
end interface
<<fks regions: procedures>>=
subroutine fks_mapping_resonances_assign (fks_map_out, fks_map_in)
type(fks_mapping_resonances_t), intent(out) :: fks_map_out
type(fks_mapping_resonances_t), intent(in) :: fks_map_in
fks_map_out%exp_1 = fks_map_in%exp_1
fks_map_out%exp_2 = fks_map_in%exp_2
fks_map_out%res_map = fks_map_in%res_map
end subroutine fks_mapping_resonances_assign
@ %def fks_mapping_resonances_assign
@
<<fks regions: public>>=
public :: create_resonance_histories_for_threshold
<<fks regions: procedures>>=
function create_resonance_histories_for_threshold () result (res_history)
type(resonance_history_t) :: res_history
res_history%n_resonances = 2
allocate (res_history%resonances (2))
allocate (res_history%resonances(1)%contributors%c(2))
allocate (res_history%resonances(2)%contributors%c(2))
res_history%resonances(1)%contributors%c = [THR_POS_WP, THR_POS_B]
res_history%resonances(2)%contributors%c = [THR_POS_WM, THR_POS_BBAR]
end function create_resonance_histories_for_threshold
@ %def create_resonance_histories_for_threshold
@
<<fks regions: public>>=
public :: setup_region_data_for_test
<<fks regions: procedures>>=
subroutine setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, nlo_corr_type)
integer, intent(in) :: n_in
integer, intent(in), dimension(:,:) :: flv_born, flv_real
type(string_t), intent(in) :: nlo_corr_type
type(region_data_t), intent(out) :: reg_data
type(model_t), pointer :: test_model => null ()
call create_test_model (var_str ("SM"), test_model)
call reg_data%init (n_in, test_model, flv_born, flv_real, nlo_corr_type)
end subroutine setup_region_data_for_test
@ %def setup_region_data_for_test
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\subsection{Unit tests}
\clearpage
<<[[fks_regions_ut.f90]]>>=
<<File header>>
module fks_regions_ut
use unit_tests
use fks_regions_uti
<<Standard module head>>
<<fks regions: public test>>
contains
<<fks regions: test driver>>
end module fks_regions_ut
@ %def fks_regions_ut
@
<<[[fks_regions_uti.f90]]>>=
<<File header>>
module fks_regions_uti
<<Use strings>>
use format_utils, only: write_separator
use os_interface
use models
use fks_regions
<<Standard module head>>
<<fks regions: test declarations>>
contains
<<fks regions: tests>>
end module fks_regions_uti
@ %def fks_regions_uti
@
<<fks regions: public test>>=
public :: fks_regions_test
<<fks regions: test driver>>=
subroutine fks_regions_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
call test(fks_regions_1, "fks_regions_1", &
"Test flavor structure utilities", u, results)
call test(fks_regions_2, "fks_regions_2", &
"Test singular regions for final-state radiation for n = 2", &
u, results)
call test(fks_regions_3, "fks_regions_3", &
"Test singular regions for final-state radiation for n = 3", &
u, results)
call test(fks_regions_4, "fks_regions_4", &
"Test singular regions for final-state radiation for n = 4", &
u, results)
call test(fks_regions_5, "fks_regions_5", &
"Test singular regions for final-state radiation for n = 5", &
u, results)
call test(fks_regions_6, "fks_regions_6", &
"Test singular regions for initial-state radiation", &
u, results)
call test(fks_regions_7, "fks_regions_7", &
"Check Latex output", u, results)
call test(fks_regions_8, "fks_regions_8", &
"Test singular regions for initial-state photon contributions", &
u, results)
end subroutine fks_regions_test
@ %def fks_regions_test
@
<<fks regions: test declarations>>=
public :: fks_regions_1
<<fks regions: tests>>=
subroutine fks_regions_1 (u)
integer, intent(in) :: u
type(flv_structure_t) :: flv_born, flv_real
type(model_t), pointer :: test_model => null ()
write (u, "(A)") "* Test output: fks_regions_1"
write (u, "(A)") "* Purpose: Test utilities of flavor structure manipulation"
write (u, "(A)")
call create_test_model (var_str ("SM"), test_model)
flv_born = [11, -11, 2, -2]
flv_real = [11, -11, 2, -2, 21]
flv_born%n_in = 2; flv_real%n_in = 2
write (u, "(A)") "* Valid splittings of ee -> uu"
write (u, "(A)") "Born Flavors: "
call flv_born%write (u)
write (u, "(A)") "Real Flavors: "
call flv_real%write (u)
write (u, "(A,L1)") "3, 4 (2, -2) : ", flv_real%valid_pair (3, 4, flv_born, test_model)
write (u, "(A,L1)") "4, 3 (-2, 2) : ", flv_real%valid_pair (4, 3, flv_born, test_model)
write (u, "(A,L1)") "3, 5 (2, 21) : ", flv_real%valid_pair (3, 5, flv_born, test_model)
write (u, "(A,L1)") "5, 3 (21, 2) : ", flv_real%valid_pair (5, 3, flv_born, test_model)
write (u, "(A,L1)") "4, 5 (-2, 21): ", flv_real%valid_pair (4, 5, flv_born, test_model)
write (u, "(A,L1)") "5, 4 (21, -2): ", flv_real%valid_pair (5, 4, flv_born, test_model)
call write_separator (u)
call flv_born%final ()
call flv_real%final ()
flv_born = [2, -2, 11, -11]
flv_real = [2, -2, 11, -11, 21]
flv_born%n_in = 2; flv_real%n_in = 2
write (u, "(A)") "* Valid splittings of uu -> ee"
write (u, "(A)") "Born Flavors: "
call flv_born%write (u)
write (u, "(A)") "Real Flavors: "
call flv_real%write (u)
write (u, "(A,L1)") "1, 2 (2, -2) : " , flv_real%valid_pair (1, 2, flv_born, test_model)
write (u, "(A,L1)") "2, 1 (-2, 2) : " , flv_real%valid_pair (2, 1, flv_born, test_model)
write (u, "(A,L1)") "5, 2 (21, -2): " , flv_real%valid_pair (5, 2, flv_born, test_model)
write (u, "(A,L1)") "2, 5 (-2, 21): " , flv_real%valid_pair (2, 5, flv_born, test_model)
write (u, "(A,L1)") "1, 5 (21, 2) : " , flv_real%valid_pair (5, 1, flv_born, test_model)
write (u, "(A,L1)") "5, 1 (2, 21) : " , flv_real%valid_pair (1, 5, flv_born, test_model)
call flv_real%final ()
flv_real = [21, -2, 11, -11, -2]
flv_real%n_in = 2
write (u, "(A)") "Real Flavors: "
call flv_real%write (u)
write (u, "(A,L1)") "1, 2 (21, -2): " , flv_real%valid_pair (1, 2, flv_born, test_model)
write (u, "(A,L1)") "2, 1 (-2, 21): " , flv_real%valid_pair (2, 1, flv_born, test_model)
write (u, "(A,L1)") "5, 2 (-2, -2): " , flv_real%valid_pair (5, 2, flv_born, test_model)
write (u, "(A,L1)") "2, 5 (-2, -2): " , flv_real%valid_pair (2, 5, flv_born, test_model)
write (u, "(A,L1)") "5, 1 (-2, 21): " , flv_real%valid_pair (5, 1, flv_born, test_model)
write (u, "(A,L1)") "1, 5 (21, -2): " , flv_real%valid_pair (1, 5, flv_born, test_model)
call flv_real%final ()
flv_real = [2, 21, 11, -11, 2]
flv_real%n_in = 2
write (u, "(A)") "Real Flavors: "
call flv_real%write (u)
write (u, "(A,L1)") "1, 2 (2, 21) : " , flv_real%valid_pair (1, 2, flv_born, test_model)
write (u, "(A,L1)") "2, 1 (21, 2) : " , flv_real%valid_pair (2, 1, flv_born, test_model)
write (u, "(A,L1)") "5, 2 (2, 21) : " , flv_real%valid_pair (5, 2, flv_born, test_model)
write (u, "(A,L1)") "2, 5 (21, 2) : " , flv_real%valid_pair (2, 5, flv_born, test_model)
write (u, "(A,L1)") "5, 1 (2, 2) : " , flv_real%valid_pair (5, 1, flv_born, test_model)
write (u, "(A,L1)") "1, 5 (2, 2) : " , flv_real%valid_pair (1, 5, flv_born, test_model)
call write_separator (u)
call flv_born%final ()
call flv_real%final ()
flv_born = [11, -11, 2, -2, 21]
flv_real = [11, -11, 2, -2, 21, 21]
flv_born%n_in = 2; flv_real%n_in = 2
write (u, "(A)") "* Valid splittings of ee -> uug"
write (u, "(A)") "Born Flavors: "
call flv_born%write (u)
write (u, "(A)") "Real Flavors: "
call flv_real%write (u)
write (u, "(A,L1)") "3, 4 (2, -2) : " , flv_real%valid_pair (3, 4, flv_born, test_model)
write (u, "(A,L1)") "4, 3 (-2, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model)
write (u, "(A,L1)") "3, 5 (2, 21) : " , flv_real%valid_pair (3, 5, flv_born, test_model)
write (u, "(A,L1)") "5, 3 (21, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model)
write (u, "(A,L1)") "4, 5 (-2, 21): " , flv_real%valid_pair (4, 5, flv_born, test_model)
write (u, "(A,L1)") "5, 4 (21, -2): " , flv_real%valid_pair (5, 4, flv_born, test_model)
write (u, "(A,L1)") "3, 6 (2, 21) : " , flv_real%valid_pair (3, 6, flv_born, test_model)
write (u, "(A,L1)") "6, 3 (21, 2) : " , flv_real%valid_pair (6, 3, flv_born, test_model)
write (u, "(A,L1)") "4, 6 (-2, 21): " , flv_real%valid_pair (4, 6, flv_born, test_model)
write (u, "(A,L1)") "6, 4 (21, -2): " , flv_real%valid_pair (6, 4, flv_born, test_model)
write (u, "(A,L1)") "5, 6 (21, 21): " , flv_real%valid_pair (5, 6, flv_born, test_model)
write (u, "(A,L1)") "6, 5 (21, 21): " , flv_real%valid_pair (6, 5, flv_born, test_model)
call flv_real%final ()
flv_real = [11, -11, 2, -2, 1, -1]
flv_real%n_in = 2
write (u, "(A)") "Real Flavors (exemplary g -> dd splitting): "
call flv_real%write (u)
write (u, "(A,L1)") "3, 4 (2, -2) : " , flv_real%valid_pair (3, 4, flv_born, test_model)
write (u, "(A,L1)") "4, 3 (-2, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model)
write (u, "(A,L1)") "3, 5 (2, 1) : " , flv_real%valid_pair (3, 5, flv_born, test_model)
write (u, "(A,L1)") "5, 3 (1, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model)
write (u, "(A,L1)") "4, 5 (-2, 1) : " , flv_real%valid_pair (4, 5, flv_born, test_model)
write (u, "(A,L1)") "5, 4 (1, -2) : " , flv_real%valid_pair (5, 4, flv_born, test_model)
write (u, "(A,L1)") "3, 6 (2, -1) : " , flv_real%valid_pair (3, 6, flv_born, test_model)
write (u, "(A,L1)") "6, 3 (-1, 2) : " , flv_real%valid_pair (6, 3, flv_born, test_model)
write (u, "(A,L1)") "4, 6 (-2, -1): " , flv_real%valid_pair (4, 6, flv_born, test_model)
write (u, "(A,L1)") "6, 4 (-1, -2): " , flv_real%valid_pair (6, 4, flv_born, test_model)
write (u, "(A,L1)") "5, 6 (1, -1) : " , flv_real%valid_pair (5, 6, flv_born, test_model)
write (u, "(A,L1)") "6, 5 (-1, 1) : " , flv_real%valid_pair (6, 5, flv_born, test_model)
call write_separator (u)
call flv_born%final ()
call flv_real%final ()
flv_born = [6, -5, 2, -1 ]
flv_real = [6, -5, 2, -1, 21]
flv_born%n_in = 1; flv_real%n_in = 1
write (u, "(A)") "* Valid splittings of t -> b u d~"
write (u, "(A)") "Born Flavors: "
call flv_born%write (u)
write (u, "(A)") "Real Flavors: "
call flv_real%write (u)
write (u, "(A,L1)") "1, 2 (6, -5) : " , flv_real%valid_pair (1, 2, flv_born, test_model)
write (u, "(A,L1)") "1, 3 (6, 2) : " , flv_real%valid_pair (1, 3, flv_born, test_model)
write (u, "(A,L1)") "1, 4 (6, -1) : " , flv_real%valid_pair (1, 4, flv_born, test_model)
write (u, "(A,L1)") "2, 1 (-5, 6) : " , flv_real%valid_pair (2, 1, flv_born, test_model)
write (u, "(A,L1)") "3, 1 (2, 6) : " , flv_real%valid_pair (3, 1, flv_born, test_model)
write (u, "(A,L1)") "4, 1 (-1, 6) : " , flv_real%valid_pair (4, 1, flv_born, test_model)
write (u, "(A,L1)") "2, 3 (-5, 2) : " , flv_real%valid_pair (2, 3, flv_born, test_model)
write (u, "(A,L1)") "2, 4 (-5, -1): " , flv_real%valid_pair (2, 4, flv_born, test_model)
write (u, "(A,L1)") "3, 2 (2, -5) : " , flv_real%valid_pair (3, 2, flv_born, test_model)
write (u, "(A,L1)") "4, 2 (-1, -5): " , flv_real%valid_pair (4, 2, flv_born, test_model)
write (u, "(A,L1)") "3, 4 (2, -1) : " , flv_real%valid_pair (3, 4, flv_born, test_model)
write (u, "(A,L1)") "4, 3 (-1, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model)
write (u, "(A,L1)") "1, 5 (6, 21) : " , flv_real%valid_pair (1, 5, flv_born, test_model)
write (u, "(A,L1)") "5, 1 (21, 6) : " , flv_real%valid_pair (5, 1, flv_born, test_model)
write (u, "(A,L1)") "2, 5 (-5, 21): " , flv_real%valid_pair (2, 5, flv_born, test_model)
write (u, "(A,L1)") "5, 2 (21, 5) : " , flv_real%valid_pair (5, 2, flv_born, test_model)
write (u, "(A,L1)") "3, 5 (2, 21) : " , flv_real%valid_pair (3, 5, flv_born, test_model)
write (u, "(A,L1)") "5, 3 (21, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model)
write (u, "(A,L1)") "4, 5 (-1, 21): " , flv_real%valid_pair (4, 5, flv_born, test_model)
write (u, "(A,L1)") "5, 4 (21, -1): " , flv_real%valid_pair (5, 4, flv_born, test_model)
call flv_born%final ()
call flv_real%final ()
end subroutine fks_regions_1
@ %def fks_regions_1
@
<<fks regions: test declarations>>=
public :: fks_regions_2
<<fks regions: tests>>=
subroutine fks_regions_2 (u)
integer, intent(in) :: u
integer :: n_flv_born, n_flv_real
integer :: n_legs_born, n_legs_real
integer :: n_in
integer, dimension(:,:), allocatable :: flv_born, flv_real
type(region_data_t) :: reg_data
write (u, "(A)") "* Test output: fks_regions_2"
write (u, "(A)") "* Create singular regions for processes with up to four singular regions"
write (u, "(A)") "* ee -> qq with QCD corrections"
write (u, "(A)")
n_flv_born = 1; n_flv_real = 1
n_legs_born = 4; n_legs_real = 5
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [11, -11, 2, -2]
flv_real (:, 1) = [11, -11, 2, -2, 21]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
call write_separator (u)
write (u, "(A)") "* ee -> qq with QED corrections"
write (u, "(A)")
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [11, -11, 2, -2]
flv_real (:, 1) = [11, -11, 2, -2, 22]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QED"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
call write_separator (u)
write (u, "(A)") "* ee -> tt"
write (u, "(A)")
write (u, "(A)") "* This process has four singular regions because they are not equivalent."
n_flv_born = 1; n_flv_real = 1
n_legs_born = 6; n_legs_real = 7
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [11, -11, 6, -6, 6, -6]
flv_real (:, 1) = [11, -11, 6, -6, 6, -6, 21]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
end subroutine fks_regions_2
@ %def fks_regions_2
@
<<fks regions: test declarations>>=
public :: fks_regions_3
<<fks regions: tests>>=
subroutine fks_regions_3 (u)
integer, intent(in) :: u
integer :: n_flv_born, n_flv_real
integer :: n_legs_born, n_legs_real
integer :: n_in, i, j
integer, dimension(:,:), allocatable :: flv_born, flv_real
type(region_data_t) :: reg_data
write (u, "(A)") "* Test output: fks_regions_3"
write (u, "(A)") "* Create singular regions for processes with three final-state particles"
write (u, "(A)") "* ee -> qqg"
write (u, "(A)")
n_flv_born = 1; n_flv_real = 2
n_legs_born = 5; n_legs_real = 6
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [11, -11, 2, -2, 21]
flv_real (:, 1) = [11, -11, 2, -2, 21, 21]
flv_real (:, 2) = [11, -11, 2, -2, 1, -1]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
call write_separator (u)
write (u, "(A)") "* ee -> qqA"
write (u, "(A)")
n_flv_born = 1; n_flv_real = 2
n_legs_born = 5; n_legs_real = 6
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [11, -11, 2, -2, 22]
flv_real (:, 1) = [11, -11, 2, -2, 22, 22]
flv_real (:, 2) = [11, -11, 2, -2, 11, -11]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QED"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
call write_separator (u)
write (u, "(A)") "* ee -> jet jet jet"
write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl"
write (u, "(A)")
n_flv_born = 5; n_flv_real = 22
n_legs_born = 5; n_legs_real = 6
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [11, -11, -4, 4, 21]
flv_born (:, 2) = [11, -11, -2, 2, 21]
flv_born (:, 3) = [11, -11, -5, 5, 21]
flv_born (:, 4) = [11, -11, -3, 3, 21]
flv_born (:, 5) = [11, -11, -1, 1, 21]
flv_real (:, 1) = [11, -11, -4, -4, 4, 4]
flv_real (:, 2) = [11, -11, -4, -2, 2, 4]
flv_real (:, 3) = [11, -11, -4, 4, 21, 21]
flv_real (:, 4) = [11, -11, -4, -5, 4, 5]
flv_real (:, 5) = [11, -11, -4, -3, 4, 3]
flv_real (:, 6) = [11, -11, -4, -1, 2, 3]
flv_real (:, 7) = [11, -11, -4, -1, 4, 1]
flv_real (:, 8) = [11, -11, -2, -2, 2, 2]
flv_real (:, 9) = [11, -11, -2, 2, 21, 21]
flv_real (:, 10) = [11, -11, -2, -5, 2, 5]
flv_real (:, 11) = [11, -11, -2, -3, 2, 3]
flv_real (:, 12) = [11, -11, -2, -3, 4, 1]
flv_real (:, 13) = [11, -11, -2, -1, 2, 1]
flv_real (:, 14) = [11, -11, -5, -5, 5, 5]
flv_real (:, 15) = [11, -11, -5, -3, 3, 5]
flv_real (:, 16) = [11, -11, -5, -1, 1, 5]
flv_real (:, 17) = [11, -11, -5, 5, 21, 21]
flv_real (:, 18) = [11, -11, -3, -3, 3, 3]
flv_real (:, 19) = [11, -11, -3, -1, 1, 3]
flv_real (:, 20) = [11, -11, -3, 3, 21, 21]
flv_real (:, 21) = [11, -11, -1, -1, 1, 1]
flv_real (:, 22) = [11, -11, -1, 1, 21, 21]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
call write_separator (u)
write (u, "(A)") "* ee -> L L A"
write (u, "(A)") "* with L = e2:E2:e3:E3"
write (u, "(A)")
n_flv_born = 2; n_flv_real = 6
n_legs_born = 5; n_legs_real = 6
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [11, -11, -15, 15, 22]
flv_born (:, 2) = [11, -11, -13, 13, 22]
flv_real (:, 1) = [11, -11, -15, -15, 15, 15]
flv_real (:, 2) = [11, -11, -15, -13, 13, 13]
flv_real (:, 3) = [11, -11, -13, -15, 13, 15]
flv_real (:, 4) = [11, -11, -15, 15, 22, 22]
flv_real (:, 5) = [11, -11, -13, -13, 13, 13]
flv_real (:, 6) = [11, -11, -13, 13, 22, 22]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QED"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
end subroutine fks_regions_3
@ %def fks_regions_3
@
<<fks regions: test declarations>>=
public :: fks_regions_4
<<fks regions: tests>>=
subroutine fks_regions_4 (u)
integer, intent(in) :: u
integer :: n_flv_born, n_flv_real
integer :: n_legs_born, n_legs_real
integer :: n_in
integer, dimension(:,:), allocatable :: flv_born, flv_real
type(region_data_t) :: reg_data
write (u, "(A)") "* Test output: fks_regions_4"
write (u, "(A)") "* Create singular regions for processes with four final-state particles"
write (u, "(A)") "* ee -> 4 jet"
write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl"
write (u, "(A)")
n_flv_born = 22; n_flv_real = 22
n_legs_born = 6; n_legs_real = 7
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [11, -11, -4, -4, 4, 4]
flv_born (:, 2) = [11, -11, -4, -2, 2, 4]
flv_born (:, 3) = [11, -11, -4, 4, 21, 21]
flv_born (:, 4) = [11, -11, -4, -5, 4, 5]
flv_born (:, 5) = [11, -11, -4, -3, 4, 3]
flv_born (:, 6) = [11, -11, -4, -1, 2, 3]
flv_born (:, 7) = [11, -11, -4, -1, 4, 1]
flv_born (:, 8) = [11, -11, -2, -2, 2, 2]
flv_born (:, 9) = [11, -11, -2, 2, 21, 21]
flv_born (:, 10) = [11, -11, -2, -5, 2, 5]
flv_born (:, 11) = [11, -11, -2, -3, 2, 3]
flv_born (:, 12) = [11, -11, -2, -3, 4, 1]
flv_born (:, 13) = [11, -11, -2, -1, 2, 1]
flv_born (:, 14) = [11, -11, -5, -5, 5, 5]
flv_born (:, 15) = [11, -11, -5, -3, 3, 5]
flv_born (:, 16) = [11, -11, -5, -1, 1, 5]
flv_born (:, 17) = [11, -11, -5, 5, 21, 21]
flv_born (:, 18) = [11, -11, -3, -3, 3, 3]
flv_born (:, 19) = [11, -11, -3, -1, 1, 3]
flv_born (:, 20) = [11, -11, -3, -3, 21, 21]
flv_born (:, 21) = [11, -11, -1, -1, 1, 1]
flv_born (:, 22) = [11, -11, -1, 1, 21, 21]
flv_real (:, 1) = [11, -11, -4, -4, 4, 4, 21]
flv_real (:, 2) = [11, -11, -4, -2, 2, 4, 21]
flv_real (:, 3) = [11, -11, -4, 4, 21, 21, 21]
flv_real (:, 4) = [11, -11, -4, -5, 4, 5, 21]
flv_real (:, 5) = [11, -11, -4, -3, 4, 3, 21]
flv_real (:, 6) = [11, -11, -4, -1, 2, 3, 21]
flv_real (:, 7) = [11, -11, -4, -1, 4, 1, 21]
flv_real (:, 8) = [11, -11, -2, -2, 2, 2, 21]
flv_real (:, 9) = [11, -11, -2, 2, 21, 21, 21]
flv_real (:, 10) = [11, -11, -2, -5, 2, 5, 21]
flv_real (:, 11) = [11, -11, -2, -3, 2, 3, 21]
flv_real (:, 12) = [11, -11, -2, -3, 4, 1, 21]
flv_real (:, 13) = [11, -11, -2, -1, 2, 1, 21]
flv_real (:, 14) = [11, -11, -5, -5, 5, 5, 21]
flv_real (:, 15) = [11, -11, -5, -3, 3, 5, 21]
flv_real (:, 16) = [11, -11, -5, -1, 1, 5, 21]
flv_real (:, 17) = [11, -11, -5, 5, 21, 21, 21]
flv_real (:, 18) = [11, -11, -3, -3, 3, 3, 21]
flv_real (:, 19) = [11, -11, -3, -1, 1, 3, 21]
flv_real (:, 20) = [11, -11, -3, 3, 21, 21, 21]
flv_real (:, 21) = [11, -11, -1, -1, 1, 1, 21]
flv_real (:, 22) = [11, -11, -1, 1, 21, 21, 21]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
call write_separator (u)
write (u, "(A)") "* ee -> bbmumu with QCD corrections"
write (u, "(A)")
n_flv_born = 1; n_flv_real = 1
n_legs_born = 6; n_legs_real = 7
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [11, -11, -5, 5, -13, 13]
flv_real (:, 1) = [11, -11, -5, 5, -13, 13, 21]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
call write_separator (u)
write (u, "(A)") "* ee -> bbmumu with QED corrections"
write (u, "(A)")
n_flv_born = 1; n_flv_real = 1
n_legs_born = 6; n_legs_real = 7
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [11, -11, -5, 5, -13, 13]
flv_real (:, 1) = [11, -11, -5, 5, -13, 13, 22]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
end subroutine fks_regions_4
@ %def fks_regions_4
@
<<fks regions: test declarations>>=
public :: fks_regions_5
<<fks regions: tests>>=
subroutine fks_regions_5 (u)
integer, intent(in) :: u
integer :: n_flv_born, n_flv_real
integer :: n_legs_born, n_legs_real
integer :: n_in
integer, dimension(:,:), allocatable :: flv_born, flv_real
type(region_data_t) :: reg_data
write (u, "(A)") "* Test output: fks_regions_5"
write (u, "(A)") "* Create singular regions for processes with five final-state particles"
write (u, "(A)") "* ee -> 5 jet"
write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl"
write (u, "(A)")
n_flv_born = 22; n_flv_real = 67
n_legs_born = 7; n_legs_real = 8
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:,1) = [11,-11,-4,-4,4,4,21]
flv_born (:,2) = [11,-11,-4,-2,2,4,21]
flv_born (:,3) = [11,-11,-4,4,21,21,21]
flv_born (:,4) = [11,-11,-4,-5,4,5,21]
flv_born (:,5) = [11,-11,-4,-3,4,3,21]
flv_born (:,6) = [11,-11,-4,-1,2,3,21]
flv_born (:,7) = [11,-11,-4,-1,4,1,21]
flv_born (:,8) = [11,-11,-2,-2,2,2,21]
flv_born (:,9) = [11,-11,-2,2,21,21,21]
flv_born (:,10) = [11,-11,-2,-5,2,5,21]
flv_born (:,11) = [11,-11,-2,-3,2,3,21]
flv_born (:,12) = [11,-11,-2,-3,4,1,21]
flv_born (:,13) = [11,-11,-2,-1,2,1,21]
flv_born (:,14) = [11,-11,-5,-5,5,5,21]
flv_born (:,15) = [11,-11,-5,-3,3,5,21]
flv_born (:,16) = [11,-11,-5,-1,1,5,21]
flv_born (:,17) = [11,-11,-5,5,21,21,21]
flv_born (:,18) = [11,-11,-3,-3,3,3,21]
flv_born (:,19) = [11,-11,-3,-1,1,3,21]
flv_born (:,20) = [11,-11,-3,3,21,21,21]
flv_born (:,21) = [11,-11,-1,-1,1,1,21]
flv_born (:,22) = [11,-11,-1,1,21,21,21]
flv_real (:,1) = [11,-11,-4,-4,-4,4,4,4]
flv_real (:,2) = [11,-11,-4,-4,-2,2,4,4]
flv_real (:,3) = [11,-11,-4,-4,4,4,21,21]
flv_real (:,4) = [11,-11,-4,-4,-5,4,4,5]
flv_real (:,5) = [11,-11,-4,-4,-3,4,4,3]
flv_real (:,6) = [11,-11,-4,-4,-1,2,4,3]
flv_real (:,7) = [11,-11,-4,-4,-1,4,4,1]
flv_real (:,8) = [11,-11,-4,-2,-2,2,2,4]
flv_real (:,9) = [11,-11,-4,-2,2,4,21,21]
flv_real (:,10) = [11,-11,-4,-2,-5,2,4,5]
flv_real (:,11) = [11,-11,-4,-2,-3,2,4,3]
flv_real (:,12) = [11,-11,-4,-2,-3,4,4,1]
flv_real (:,13) = [11,-11,-4,-2,-1,2,2,3]
flv_real (:,14) = [11,-11,-4,-2,-1,2,4,1]
flv_real (:,15) = [11,-11,-4,4,21,21,21,21]
flv_real (:,16) = [11,-11,-4,-5,4,5,21,21]
flv_real (:,17) = [11,-11,-4,-5,-5,4,5,5]
flv_real (:,18) = [11,-11,-4,-5,-3,4,3,5]
flv_real (:,19) = [11,-11,-4,-5,-1,2,3,5]
flv_real (:,20) = [11,-11,-4,-5,-1,4,1,5]
flv_real (:,21) = [11,-11,-4,-3,4,3,21,21]
flv_real (:,22) = [11,-11,-4,-3,-3,4,3,3]
flv_real (:,23) = [11,-11,-4,-3,-1,2,3,3]
flv_real (:,24) = [11,-11,-4,-3,-1,4,1,3]
flv_real (:,25) = [11,-11,-4,-1,2,3,21,21]
flv_real (:,26) = [11,-11,-4,-1,4,1,21,21]
flv_real (:,27) = [11,-11,-4,-1,-1,2,1,3]
flv_real (:,28) = [11,-11,-4,-1,-1,4,1,1]
flv_real (:,29) = [11,-11,-2,-2,-2,2,2,2]
flv_real (:,30) = [11,-11,-2,-2,2,2,21,21]
flv_real (:,31) = [11,-11,-2,-2,-5,2,2,5]
flv_real (:,32) = [11,-11,-2,-2,-3,2,2,3]
flv_real (:,33) = [11,-11,-2,-2,-3,2,4,1]
flv_real (:,34) = [11,-11,-2,-2,-1,2,2,1]
flv_real (:,35) = [11,-11,-2,2,21,21,21,21]
flv_real (:,36) = [11,-11,-2,-5,2,5,21,21]
flv_real (:,37) = [11,-11,-2,-5,-5,2,5,5]
flv_real (:,38) = [11,-11,-2,-5,-3,2,3,5]
flv_real (:,39) = [11,-11,-2,-5,-3,4,1,5]
flv_real (:,40) = [11,-11,-2,-5,-1,2,1,5]
flv_real (:,41) = [11,-11,-2,-3,2,3,21,21]
flv_real (:,42) = [11,-11,-2,-3,4,1,21,21]
flv_real (:,43) = [11,-11,-2,-3,-3,2,3,3]
flv_real (:,44) = [11,-11,-2,-3,-3,4,1,3]
flv_real (:,45) = [11,-11,-2,-3,-1,2,1,3]
flv_real (:,46) = [11,-11,-2,-3,-1,4,1,1]
flv_real (:,47) = [11,-11,-2,-1,2,1,21,21]
flv_real (:,48) = [11,-11,-2,-1,-1,2,1,1]
flv_real (:,49) = [11,-11,-5,-5,-5,5,5,5]
flv_real (:,50) = [11,-11,-5,-5,-3,3,5,5]
flv_real (:,51) = [11,-11,-5,-5,-1,1,5,5]
flv_real (:,52) = [11,-11,-5,-5,5,5,21,21]
flv_real (:,53) = [11,-11,-5,-3,-3,3,3,5]
flv_real (:,54) = [11,-11,-5,-3,-1,1,3,5]
flv_real (:,55) = [11,-11,-5,-3,3,5,21,21]
flv_real (:,56) = [11,-11,-5,-1,-1,1,1,5]
flv_real (:,57) = [11,-11,-5,-1,1,5,21,21]
flv_real (:,58) = [11,-11,-5,5,21,21,21,21]
flv_real (:,59) = [11,-11,-3,-3,-3,3,3,3]
flv_real (:,60) = [11,-11,-3,-3,-1,1,3,3]
flv_real (:,61) = [11,-11,-3,-3,3,3,21,21]
flv_real (:,62) = [11,-11,-3,-1,-1,1,1,3]
flv_real (:,63) = [11,-11,-3,-1,1,3,21,21]
flv_real (:,64) = [11,-11,-3,3,21,21,21,21]
flv_real (:,65) = [11,-11,-1,-1,-1,1,1,1]
flv_real (:,66) = [11,-11,-1,-1,1,1,21,21]
flv_real (:,67) = [11,-11,-1,1,21,21,21,21]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
end subroutine fks_regions_5
@ %def fks_regions_5
@
<<fks regions: test declarations>>=
public :: fks_regions_6
<<fks regions: tests>>=
subroutine fks_regions_6 (u)
integer, intent(in) :: u
integer :: n_flv_born, n_flv_real
integer :: n_legs_born, n_legs_real
integer :: n_in
integer, dimension(:,:), allocatable :: flv_born, flv_real
type(region_data_t) :: reg_data
integer :: i, j
integer, dimension(10) :: flavors
write (u, "(A)") "* Test output: fks_regions_6"
write (u, "(A)") "* Create table of singular regions for Drell Yan"
write (u, "(A)")
n_flv_born = 10; n_flv_real = 30
n_legs_born = 4; n_legs_real = 5
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flavors = [-5, -4, -3, -2, -1, 1, 2, 3, 4, 5]
do i = 1, n_flv_born
flv_born (3:4, i) = [11, -11]
end do
do j = 1, n_flv_born
flv_born (1, j) = flavors (j)
flv_born (2, j) = -flavors (j)
end do
do i = 1, n_flv_real
flv_real (3:4, i) = [11, -11]
end do
i = 1
do j = 1, n_flv_real
if (mod (j, 3) == 1) then
flv_real (1, j) = flavors (i)
flv_real (2, j) = -flavors (i)
flv_real (5, j) = 21
else if (mod (j, 3) == 2) then
flv_real (1, j) = flavors (i)
flv_real (2, j) = 21
flv_real (5, j) = flavors (i)
else
flv_real (1, j) = 21
flv_real (2, j) = -flavors (i)
flv_real (5, j) = -flavors (i)
i = i + 1
end if
end do
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
call write_separator (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
write (u, "(A)") "* Create table of singular regions for hadronic top decay"
write (u, "(A)")
n_flv_born = 1; n_flv_real = 1
n_legs_born = 4; n_legs_real = 5
n_in = 1
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [6, -5, 2, -1]
flv_real (:, 1) = [6, -5, 2, -1, 21]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
call write_separator (u)
deallocate (flv_born, flv_real)
call reg_data%final ()
write (u, "(A)") "* Create table of singular regions for dijet s sbar -> jet jet"
write (u, "(A)") "* With jet = u:d:gl"
write (u, "(A)")
n_flv_born = 3; n_flv_real = 3
n_legs_born = 4; n_legs_real = 5
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
do i = 1, n_flv_born
flv_born (1:2, i) = [3, -3]
end do
flv_born (3, :) = [1, 2, 21]
flv_born (4, :) = [-1, -2, 21]
do i = 1, n_flv_real
flv_real (1:2, i) = [3, -3]
end do
flv_real (3, :) = [1, 2, 21]
flv_real (4, :) = [-1, -2, 21]
flv_real (5, :) = [21, 21, 21]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
call reg_data%final ()
end subroutine fks_regions_6
@ %def fks_regions_6
@
<<fks regions: test declarations>>=
public :: fks_regions_7
<<fks regions: tests>>=
subroutine fks_regions_7 (u)
integer, intent(in) :: u
integer :: n_flv_born, n_flv_real
integer :: n_legs_born, n_legs_real
integer :: n_in
integer, dimension(:,:), allocatable :: flv_born, flv_real
type(region_data_t) :: reg_data
write (u, "(A)") "* Test output: fks_regions_7"
write (u, "(A)") "* Create table of singular regions for ee -> qq"
write (u, "(A)")
n_flv_born = 1; n_flv_real = 1
n_legs_born = 4; n_legs_real = 5
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [11, -11, 2, -2]
flv_real (:, 1) = [11, -11, 2, -2, 21]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
call reg_data%write_latex (u)
call reg_data%final ()
end subroutine fks_regions_7
@ %def fks_regions_7
@
<<fks regions: test declarations>>=
public :: fks_regions_8
<<fks regions: tests>>=
subroutine fks_regions_8 (u)
integer, intent(in) :: u
integer :: n_flv_born, n_flv_real
integer :: n_legs_born, n_legs_real
integer :: n_in
integer, dimension(:,:), allocatable :: flv_born, flv_real
type(region_data_t) :: reg_data
integer :: i, j
integer, dimension(10) :: flavors
write (u, "(A)") "* Test output: fks_regions_8"
write (u, "(A)") "* Create table of singular regions for ee -> ee"
write (u, "(A)")
n_flv_born = 1; n_flv_real = 3
n_legs_born = 4; n_legs_real = 5
n_in = 2
allocate (flv_born (n_legs_born, n_flv_born))
allocate (flv_real (n_legs_real, n_flv_real))
flv_born (:, 1) = [11, -11, -11, 11]
flv_real (:, 1) = [11, -11, -11, 11, 22]
flv_real (:, 2) = [11, 22, -11, 11, 11]
flv_real (:, 3) = [22, -11, 11, -11, -11]
call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QED"))
call reg_data%check_consistency (.false., u)
call reg_data%write (u)
call reg_data%final ()
end subroutine fks_regions_8
@ %def fks_regions_8
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Virtual contribution to the cross section}
<<[[virtual.f90]]>>=
<<File header>>
module virtual
<<Use kinds>>
<<Use strings>>
<<Use debug>>
use numeric_utils
use constants
use diagnostics
use pdg_arrays
use models
use model_data, only: model_data_t
use physics_defs
use sm_physics
use lorentz
use flavors
use nlo_data, only: get_threshold_momenta, nlo_settings_t
use nlo_data, only: ASSOCIATED_LEG_PAIR
use fks_regions
<<Standard module head>>
<<virtual: public>>
<<virtual: parameters>>
<<virtual: types>>
contains
<<virtual: procedures>>
end module virtual
@ %def virtual
@
<<virtual: public>>=
public :: virtual_t
<<virtual: types>>=
type :: virtual_t
type(nlo_settings_t), pointer :: settings
real(default), dimension(:,:), allocatable :: gamma_0, gamma_p, c_flv
real(default) :: ren_scale2, fac_scale, es_scale2
integer, dimension(:), allocatable :: n_is_neutrinos
integer :: n_in, n_legs, n_flv
logical :: bad_point = .false.
type(string_t) :: selection
real(default), dimension(:), allocatable :: sqme_born
real(default), dimension(:), allocatable :: sqme_virt_fin
real(default), dimension(:,:,:), allocatable :: sqme_color_c
real(default), dimension(:,:,:), allocatable :: sqme_charge_c
logical :: has_pdfs = .false.
contains
<<virtual: virtual: TBP>>
end type virtual_t
@ %def virtual_t
@
<<virtual: virtual: TBP>>=
procedure :: init => virtual_init
<<virtual: procedures>>=
subroutine virtual_init (virt, flv_born, n_in, settings, &
nlo_corr_type, model, has_pdfs)
class(virtual_t), intent(inout) :: virt
integer, intent(in), dimension(:,:) :: flv_born
integer, intent(in) :: n_in
type(nlo_settings_t), intent(in), pointer :: settings
type(string_t), intent(in) :: nlo_corr_type
class(model_data_t), intent(in) :: model
logical, intent(in) :: has_pdfs
integer :: i_flv
virt%n_legs = size (flv_born, 1); virt%n_flv = size (flv_born, 2)
virt%n_in = n_in
allocate (virt%sqme_born (virt%n_flv))
allocate (virt%sqme_virt_fin (virt%n_flv))
allocate (virt%sqme_color_c (virt%n_legs, virt%n_legs, virt%n_flv))
allocate (virt%sqme_charge_c (virt%n_legs, virt%n_legs, virt%n_flv))
allocate (virt%gamma_0 (virt%n_legs, virt%n_flv), &
virt%gamma_p (virt%n_legs, virt%n_flv), &
virt%c_flv (virt%n_legs, virt%n_flv))
call virt%init_constants (flv_born, settings%fks_template%n_f, nlo_corr_type, model)
allocate (virt%n_is_neutrinos (virt%n_flv))
virt%n_is_neutrinos = 0
do i_flv = 1, virt%n_flv
if (is_neutrino (flv_born(1, i_flv))) &
virt%n_is_neutrinos(i_flv) = virt%n_is_neutrinos(i_flv) + 1
if (is_neutrino (flv_born(2, i_flv))) &
virt%n_is_neutrinos(i_flv) = virt%n_is_neutrinos(i_flv) + 1
end do
select case (char (settings%virtual_selection))
case ("Full", "OLP", "Subtraction")
virt%selection = settings%virtual_selection
case default
call msg_fatal ('Virtual selection: Possible values are "Full", "OLP" or "Subtraction')
end select
virt%settings => settings
virt%has_pdfs = has_pdfs
contains
function is_neutrino (flv) result (neutrino)
integer, intent(in) :: flv
logical :: neutrino
neutrino = (abs(flv) == 12 .or. abs(flv) == 14 .or. abs(flv) == 16)
end function is_neutrino
end subroutine virtual_init
@ %def virtual_init
@ The virtual subtraction terms contain Casimir operators and derived constants, listed
below:
\begin{align}
\label{eqn:C(q)}
C(q) = C(\bar{q}) &= C_F, \\
\label{eqn:C(g)}
C(g) &= C_A,\\
\label{eqn:gamma(q)}
\gamma(q) = \gamma(\bar{q}) &= \frac{3}{2} C_F,\\
\label{eqn:gamma(g)}
\gamma(g) &= \frac{11}{6} C_A - \frac{2}{3} T_F N_f,\\
\label{eqn:gammap(q)}
\gamma'(q) = \gamma'(\bar{q}) &= \left(\frac{13}{2} - \frac{2\pi^2}{3}\right) C_F, \\
\label{eqn:gammap(g)}
\gamma'(g) &= \left(\frac{67}{9} - \frac{2\pi^2}{3}\right) C_A - \frac{23}{9} T_F N_f.
\end{align}
For uncolored particles, [[virtual_init_constants]] sets $C$, $\gamma$ and $\gamma'$ to zero.
<<virtual: virtual: TBP>>=
procedure :: init_constants => virtual_init_constants
<<virtual: procedures>>=
subroutine virtual_init_constants (virt, flv_born, nf_input, nlo_corr_type, model)
class(virtual_t), intent(inout) :: virt
integer, intent(in), dimension(:,:) :: flv_born
integer, intent(in) :: nf_input
type(string_t), intent(in) :: nlo_corr_type
class(model_data_t), intent(in) :: model
integer :: i_part, i_flv
real(default) :: nf, CA_factor
real(default), dimension(:,:), allocatable :: CF_factor, TR_factor
type(flavor_t) :: flv
allocate (CF_factor (size (flv_born, 1), size (flv_born, 2)), &
TR_factor (size (flv_born, 1), size (flv_born, 2)))
if (nlo_corr_type == "QCD") then
CA_factor = CA; CF_factor = CF; TR_factor = TR
nf = real(nf_input, default)
else if (nlo_corr_type == "QED") then
CA_factor = zero
do i_flv = 1, size (flv_born, 2)
do i_part = 1, size (flv_born, 1)
call flv%init (flv_born(i_part, i_flv), model)
CF_factor(i_part, i_flv) = (flv%get_charge ())**2
TR_factor(i_part, i_flv) = (flv%get_charge ())**2
end do
end do
! TODO vincent_r fixed nf needs replacement !!! for testing only, needs dynamical treatment!
nf = real(4, default)
end if
do i_flv = 1, size (flv_born, 2)
do i_part = 1, size (flv_born, 1)
if (is_corresponding_vector (flv_born(i_part, i_flv), nlo_corr_type)) then
virt%gamma_0(i_part, i_flv) = 11._default / 6._default * CA_factor &
- two / three * TR_factor(i_part, i_flv) * nf
virt%gamma_p(i_part, i_flv) = (67._default / 9._default &
- two * pi**2 / three) * CA_factor &
- 23._default / 9._default * TR_factor(i_part, i_flv) * nf
virt%c_flv(i_part, i_flv) = CA_factor
else if (is_corresponding_fermion (flv_born(i_part, i_flv), nlo_corr_type)) then
virt%gamma_0(i_part, i_flv) = 1.5_default * CF_factor(i_part, i_flv)
virt%gamma_p(i_part, i_flv) = (6.5_default - two * pi**2 / three) * CF_factor(i_part, i_flv)
virt%c_flv(i_part, i_flv) = CF_factor(i_part, i_flv)
else
virt%gamma_0(i_part, i_flv) = zero
virt%gamma_p(i_part, i_flv) = zero
virt%c_flv(i_part, i_flv) = zero
end if
end do
end do
contains
function is_corresponding_vector (pdg_nr, nlo_corr_type)
logical :: is_corresponding_vector
integer, intent(in) :: pdg_nr
type(string_t), intent(in) :: nlo_corr_type
is_corresponding_vector = .false.
if (nlo_corr_type == "QCD") then
is_corresponding_vector = is_gluon (pdg_nr)
else if (nlo_corr_type == "QED") then
is_corresponding_vector = is_photon (pdg_nr)
end if
end function is_corresponding_vector
function is_corresponding_fermion (pdg_nr, nlo_corr_type)
logical :: is_corresponding_fermion
integer, intent(in) :: pdg_nr
type(string_t), intent(in) :: nlo_corr_type
is_corresponding_fermion = .false.
if (nlo_corr_type == "QCD") then
is_corresponding_fermion = is_quark (pdg_nr)
else if (nlo_corr_type == "QED") then
is_corresponding_fermion = is_fermion (pdg_nr)
end if
end function is_corresponding_fermion
end subroutine virtual_init_constants
@ %def virtual_init_constants
@ Set the renormalization scale. If the input is zero, use the
center-of-mass energy.
<<virtual: virtual: TBP>>=
procedure :: set_ren_scale => virtual_set_ren_scale
<<virtual: procedures>>=
subroutine virtual_set_ren_scale (virt, p, ren_scale)
class(virtual_t), intent(inout) :: virt
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: ren_scale
if (ren_scale > 0) then
virt%ren_scale2 = ren_scale**2
else
virt%ren_scale2 = (p(1) + p(2))**2
end if
end subroutine virtual_set_ren_scale
@ %def virtual_set_ren_scale
@
<<virtual: virtual: TBP>>=
procedure :: set_fac_scale => virtual_set_fac_scale
<<virtual: procedures>>=
subroutine virtual_set_fac_scale (virt, p, fac_scale)
class(virtual_t), intent(inout) :: virt
type(vector4_t), dimension(:), intent(in) :: p
real(default), optional :: fac_scale
if (present (fac_scale)) then
virt%fac_scale = fac_scale
else
virt%fac_scale = (p(1) + p(2))**1
end if
end subroutine virtual_set_fac_scale
@ %def virtual_set_fac_scale
<<virtual: virtual: TBP>>=
procedure :: set_ellis_sexton_scale => virtual_set_ellis_sexton_scale
<<virtual: procedures>>=
subroutine virtual_set_ellis_sexton_scale (virt, Q2)
class(virtual_t), intent(inout) :: virt
real(default), intent(in), optional :: Q2
if (present (Q2)) then
virt%es_scale2 = Q2
else
virt%es_scale2 = virt%ren_scale2
end if
end subroutine virtual_set_ellis_sexton_scale
@ %def virtual_set_ellis_sexton_scale
@ The virtual-subtracted matrix element is given by the equation
\begin{equation}
\label{eqn:virt_sub}
\mathcal{V} = \frac{\alpha_s}{2\pi}\left(\mathcal{Q}\mathcal{B} +
\sum \mathcal{I}_{ij}\mathcal{B}_{ij} + \mathcal{V}_{fin}\right),
\end{equation}
The expressions for $\mathcal{Q}$ can be found in equations \ref{eqn:virt_Q_isr}
and \ref{eqn:virt_Q_fsr}.
The expressions for $\mathcal{I}_{ij}$ can be found in equations
(\ref{I_00}), (\ref{I_mm}), (\ref{I_0m}), depending on whether the
particles involved in the radiation process are massive or massless.
<<virtual: virtual: TBP>>=
procedure :: evaluate => virtual_evaluate
<<virtual: procedures>>=
subroutine virtual_evaluate (virt, reg_data, alpha_coupling, &
p_born, separate_alrs, sqme_virt)
class(virtual_t), intent(inout) :: virt
type(region_data_t), intent(in) :: reg_data
real(default), intent(in) :: alpha_coupling
type(vector4_t), intent(in), dimension(:) :: p_born
logical, intent(in) :: separate_alrs
real(default), dimension(:), intent(inout) :: sqme_virt
real(default) :: s, s_o_Q2
real(default), dimension(reg_data%n_flv_born) :: QB, BI
integer :: i_flv, ii_flv
QB = zero; BI = zero
if (virt%bad_point) return
if (debug2_active (D_VIRTUAL)) then
print *, 'Compute virtual component using alpha = ', alpha_coupling
print *, 'Virtual selection: ', char (virt%selection)
print *, 'virt%es_scale2 = ', virt%es_scale2 !!! Debugging
end if
s = sum (p_born(1 : virt%n_in))**2
if (virt%settings%factorization_mode == FACTORIZATION_THRESHOLD) &
call set_s_for_threshold ()
s_o_Q2 = s / virt%es_scale2 * virt%settings%fks_template%xi_cut**2
do i_flv = 1, reg_data%n_flv_born
if (separate_alrs) then
ii_flv = i_flv
else
ii_flv = 1
end if
if (virt%selection == var_str ("Full") .or. virt%selection == var_str ("OLP")) then
!!! A factor of alpha_coupling/twopi is assumed to be included in vfin
sqme_virt(ii_flv) = sqme_virt(ii_flv) + virt%sqme_virt_fin(i_flv)
end if
if (virt%selection == var_str ("Full") .or. virt%selection == var_str ("Subtraction")) then
call virt%evaluate_initial_state (i_flv, QB)
call virt%compute_collinear_contribution (i_flv, p_born, sqrt(s), reg_data, QB)
select case (virt%settings%factorization_mode)
case (FACTORIZATION_THRESHOLD)
call virt%compute_eikonals_threshold (i_flv, p_born, s_o_Q2, QB, BI)
case default
call virt%compute_massive_self_eikonals (i_flv, p_born, s_o_Q2, reg_data, QB)
call virt%compute_eikonals (i_flv, p_born, s_o_Q2, reg_data, BI)
end select
if (debug2_active (D_VIRTUAL)) then
print *, 'Evaluate i_flv: ', i_flv
print *, 'sqme_born: ', virt%sqme_born (i_flv)
print *, 'Q * sqme_born: ', alpha_coupling / twopi * QB(i_flv)
print *, 'BI: ', alpha_coupling / twopi * BI(i_flv)
print *, 'vfin: ', virt%sqme_virt_fin (i_flv)
end if
sqme_virt(ii_flv) = &
sqme_virt(ii_flv) + alpha_coupling / twopi * (QB(i_flv) + BI(i_flv))
end if
end do
if (debug2_active (D_VIRTUAL)) then
call msg_debug2 (D_VIRTUAL, "virtual-subtracted matrix element(s): ")
print *, sqme_virt
end if
do i_flv = 1, reg_data%n_flv_born
if (virt%n_is_neutrinos(i_flv) > 0) &
sqme_virt = sqme_virt * virt%n_is_neutrinos(i_flv) * two
end do
contains
subroutine set_s_for_threshold ()
use ttv_formfactors, only: m1s_to_mpole
real(default) :: mtop2
mtop2 = m1s_to_mpole (sqrt(s))**2
if (s < four * mtop2) s = four * mtop2
end subroutine set_s_for_threshold
end subroutine virtual_evaluate
@ %def virtual_evaluate
@
<<virtual: virtual: TBP>>=
procedure :: compute_eikonals => virtual_compute_eikonals
<<virtual: procedures>>=
subroutine virtual_compute_eikonals (virtual, i_flv, &
p_born, s_o_Q2, reg_data, BI)
class(virtual_t), intent(inout) :: virtual
integer, intent(in) :: i_flv
type(vector4_t), intent(in), dimension(:) :: p_born
real(default), intent(in) :: s_o_Q2
type(region_data_t), intent(in) :: reg_data
real(default), intent(inout), dimension(:) :: BI
integer :: i, j
real(default) :: I_ij, BI_tmp
BI_tmp = zero
! TODO vincent_r: Split the procedure into one computing QCD eikonals and one computing QED eikonals.
! TODO vincent_r: In the best case, remove the dependency on reg_data completely.
associate (flst_born => reg_data%flv_born(i_flv), &
nlo_corr_type => reg_data%regions(1)%nlo_correction_type)
do i = 1, virtual%n_legs
do j = 1, virtual%n_legs
if (i /= j) then
if (nlo_corr_type == "QCD") then
if (flst_born%colored(i) .and. flst_born%colored(j)) then
I_ij = compute_eikonal_factor (p_born, flst_born%massive, &
i, j, s_o_Q2)
BI_tmp = BI_tmp + virtual%sqme_color_c (i, j, i_flv) * I_ij
if (debug2_active (D_VIRTUAL)) &
print *, 'b_ij: ', i, j, virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij
end if
else if (nlo_corr_type == "QED") then
I_ij = compute_eikonal_factor (p_born, flst_born%massive, &
i, j, s_o_Q2)
BI_tmp = BI_tmp + virtual%sqme_charge_c (i, j, i_flv) * I_ij
if (debug2_active (D_VIRTUAL)) &
print *, 'b_ij: ', virtual%sqme_charge_c (i, j, i_flv), 'I_ij: ', I_ij
end if
else if (debug2_active (D_VIRTUAL)) then
print *, 'b_ij: ', i, j, virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij
end if
end do
end do
if (virtual%settings%use_internal_color_correlations .or. nlo_corr_type == "QED") &
BI_tmp = BI_tmp * virtual%sqme_born (i_flv)
end associate
BI(i_flv) = BI(i_flv) + BI_tmp
end subroutine virtual_compute_eikonals
@ %def virtual_compute_eikonals
@
<<virtual: virtual: TBP>>=
procedure :: compute_eikonals_threshold => virtual_compute_eikonals_threshold
<<virtual: procedures>>=
subroutine virtual_compute_eikonals_threshold (virtual, i_flv, &
p_born, s_o_Q2, QB, BI)
class(virtual_t), intent(in) :: virtual
integer, intent(in) :: i_flv
type(vector4_t), intent(in), dimension(:) :: p_born
real(default), intent(in) :: s_o_Q2
real(default), intent(inout), dimension(:) :: QB
real(default), intent(inout), dimension(:) :: BI
type(vector4_t), dimension(4) :: p_thr
integer :: leg
BI = zero; p_thr = get_threshold_momenta (p_born)
call compute_massive_self_eikonals (virtual%sqme_born(i_flv), QB(i_flv))
do leg = 1, 2
BI(i_flv) = BI(i_flv) + evaluate_leg_pair (ASSOCIATED_LEG_PAIR(leg), i_flv)
end do
contains
subroutine compute_massive_self_eikonals (sqme_born, QB)
real(default), intent(in) :: sqme_born
real(default), intent(inout) :: QB
integer :: i
if (debug_on) call msg_debug2 (D_VIRTUAL, "compute_massive_self_eikonals")
if (debug_on) call msg_debug2 (D_VIRTUAL, "s_o_Q2", s_o_Q2)
if (debug_on) call msg_debug2 (D_VIRTUAL, "log (s_o_Q2)", log (s_o_Q2))
do i = 1, 4
QB = QB - (cf * (log (s_o_Q2) - 0.5_default * I_m_eps (p_thr(i)))) &
* sqme_born
end do
end subroutine compute_massive_self_eikonals
function evaluate_leg_pair (i_start, i_flv) result (b_ij_times_I)
real(default) :: b_ij_times_I
integer, intent(in) :: i_start, i_flv
real(default) :: I_ij
integer :: i, j
b_ij_times_I = zero
do i = i_start, i_start + 1
do j = i_start, i_start + 1
if (i /= j) then
I_ij = compute_eikonal_factor &
(p_thr, [.true., .true., .true., .true.], i, j, s_o_Q2)
b_ij_times_I = b_ij_times_I + &
virtual%sqme_color_c (i, j, i_flv) * I_ij
if (debug2_active (D_VIRTUAL)) &
print *, 'b_ij: ', virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij
end if
end do
end do
if (virtual%settings%use_internal_color_correlations) &
b_ij_times_I = b_ij_times_I * virtual%sqme_born (i_flv)
if (debug2_active (D_VIRTUAL)) then
print *, 'internal color: ', virtual%settings%use_internal_color_correlations
print *, 'b_ij_times_I = ', b_ij_times_I
print *, 'QB = ', QB
end if
end function evaluate_leg_pair
end subroutine virtual_compute_eikonals_threshold
@ %def virtual_compute_eikonals_threshold
@
<<virtual: virtual: TBP>>=
procedure :: set_bad_point => virtual_set_bad_point
<<virtual: procedures>>=
subroutine virtual_set_bad_point (virt, value)
class(virtual_t), intent(inout) :: virt
logical, intent(in) :: value
virt%bad_point = value
end subroutine virtual_set_bad_point
@ %def virtual_set_bad_point
@ The collinear limit of $\tilde{\mathcal{R}}$ can be integrated over the radiation
degrees of freedom, giving the collinear contribution to the virtual component. Its
general structure is $\mathcal{Q} \cdot \mathcal{B}$. The initial-state contribution
to $\mathcal{Q}$ is simply given by
\begin{equation}
\label{eqn:virt_Q_isr}
\mathcal{Q} = -\log\frac{\mu_F^2}{Q^2} \left(\gamma(\mathcal{I}_1) + 2 C (\mathcal{I}_1) \log(\xi_{\text{cut}}) + \gamma(\mathcal{I}_2) + 2 C (\mathcal{I}_2) \log(\xi_{\text{cut}}) \right),
\end{equation}
where $Q^2$ is the Ellis-Sexton scale and $\gamma$ is as in eqns. \ref{eqn:gamma(q)}
and \ref{eqn:gamma(g)}.\\
[[virtual_evaluate_initial_state]] computes this quantity. The loop over the
initial-state particles is only executed if we are
dealing with a scattering process, because for decays there are no virtual
initial-initial interactions.
<<virtual: virtual: TBP>>=
procedure :: evaluate_initial_state => virtual_evaluate_initial_state
<<virtual: procedures>>=
subroutine virtual_evaluate_initial_state (virt, i_flv, QB)
class(virtual_t), intent(inout) :: virt
integer, intent(in) :: i_flv
real(default), intent(inout), dimension(:) :: QB
integer :: i
if (virt%n_in == 2) then
do i = 1, virt%n_in
QB(i_flv) = QB(i_flv) - (virt%gamma_0 (i, i_flv) + two * virt%c_flv(i, i_flv) &
* log (virt%settings%fks_template%xi_cut)) &
* log(virt%fac_scale**2 / virt%es_scale2) * virt%sqme_born (i_flv)
end do
end if
end subroutine virtual_evaluate_initial_state
@ %def virtual_evaluate_initial_state
@ Same as above, but for final-state particles. The collinear limit for final-state
particles follows from the integral
\begin{equation*}
I_{+,\alpha_r} = \int d\Phi_{n+1} \frac{\xi_+^{-1-2\epsilon}}{\xi^{-1-2\epsilon}} \mathcal{R}_{\alpha_r}.
\end{equation*}
We can distinguish three situations:
\begin{enumerate}
\item $\alpha_r$ contains a massive emitter. In this case, no collinear subtraction terms is required and
the integral above irrelevant.
\item $\alpha_r$ contains a massless emitter, but resonances are not taken into account in the subtraction.
Here, $\xi_{max} = \frac{2E_{em}}{\sqrt{s}}$ is the upper bound on $\xi$.
\item $\alpha_r$ contains a massless emitter and resonance-aware subtraction is used. Here,
$\xi_{max} = \frac{2E_{em}}{\sqrt{k_{res}^2}}$.
\end{enumerate}
Before version 2.4, only situations 1 and 2 were covered. The difference between situation 2 and 3 comes
from the expansion of the plus-distribution in the integral above,
\begin{equation*}
\xi_+^{-1-2\epsilon} = \xi^{-1-2\epsilon} + \frac{1}{2\epsilon}\delta(\xi)
= \xi_{max}^{-1-2\epsilon}\left[(1-z)^{-1-2\epsilon} + \frac{\xi_{max}^{2\epsilon}}{2\epsilon}\delta(1-z)\right].
\end{equation*}
The expression from the standard FKS literature is given by
$\mathcal{Q}$ is given by
\begin{equation}
\label{eqn:virt_Q_fsr_old}
\begin{split}
\mathcal{Q} = \sum_{k=n_{in}}^{n_L^{(B)}} \left[\gamma'(\mathcal{I}_k)
- \log\frac{s\delta_o}{2Q^2}\left(\gamma(\mathcal{I}_k)
- 2C(\mathcal{I}_k) \log\frac{2E_k}{\xi_{\text{cut}}\sqrt{s}}\right) \right.\\
+ \left. 2C(\mathcal{I}_k) \left( \log^2\frac{2E_k}{\sqrt{s}} - \log^2 \xi_{\text{cut}} \right)
- 2\gamma(\mathcal{I}_k)\log\frac{2E_k}{\sqrt{s}}\right].
\end{split}
\end{equation}
$n_L^{(B)}$ is the number of legs at Born level.
Here, $\xi_{max}$ is implicitly present in the ratios in the logarithms. Using the resonance-aware $\xi_{max}$ yields
\begin{equation}
\label{eqn:virt_Q_fsr}
\begin{split}
\mathcal{Q} = \sum_{k=n_{in}}^{n_L^{(B)}} \left[\gamma'(\mathcal{I}_k)
+ 2\left(\log\frac{\sqrt{s}}{2E_{em}} + \log\xi_{max}\right)
\left(\log\frac{\sqrt{s}}{2E_{em}} + \log\xi_{max} + \log\frac{Q^2}{s}\right) C(\mathcal{I}_k) \right.\\
+ \left. 2 \log\xi_{max} \left(\log\xi_{max} - \log\frac{Q^2}{k_{res}^2}\right) C(\mathcal{I}_k)
+ \left(\log\frac{Q^2}{k_{res}^2} - 2 \log\xi_{max}\right) \gamma(\mathcal{I}_k)\right].
\end{split}
\end{equation}
Equation \ref{eqn:virt_Q_fsr} leads to \ref{eqn:virt_Q_fsr_old} with the substitutions $\xi_{max} \rightarrow \frac{2E_{em}}{\sqrt{s}}$ and $k_{res}^2 \rightarrow s$.
[[virtual_compute_collinear_contribution]] only implements the second one.
<<virtual: virtual: TBP>>=
procedure :: compute_collinear_contribution &
=> virtual_compute_collinear_contribution
<<virtual: procedures>>=
subroutine virtual_compute_collinear_contribution (virt, i_flv, &
p_born, sqrts, reg_data, QB)
class(virtual_t), intent(inout) :: virt
integer, intent(in) :: i_flv
type(vector4_t), dimension(:), intent(in) :: p_born
real(default), intent(in) :: sqrts
type(region_data_t), intent(in) :: reg_data
real(default), intent(inout), dimension(:) :: QB
real(default) :: s1, s2, s3, s4, s5
integer :: alr, em
real(default) :: E_em, xi_max, log_xi_max, E_tot2
logical, dimension(virt%n_flv, virt%n_legs) :: evaluated
integer :: i_contr
type(vector4_t) :: k_res
type(lorentz_transformation_t) :: L_to_resonance
evaluated = .false.
do alr = 1, reg_data%n_regions
if (i_flv /= reg_data%regions(alr)%uborn_index) cycle
em = reg_data%regions(alr)%emitter
if (em == 0) cycle
if (evaluated(i_flv, em)) cycle
!!! Collinear terms only for massless particles
if (reg_data%regions(alr)%flst_uborn%massive(em)) cycle
E_em = p_born(em)%p(0)
if (allocated (reg_data%alr_contributors)) then
i_contr = reg_data%alr_to_i_contributor (alr)
k_res = get_resonance_momentum (p_born, reg_data%alr_contributors(i_contr)%c)
E_tot2 = k_res%p(0)**2
L_to_resonance = inverse (boost (k_res, k_res**1))
xi_max = two * space_part_norm (L_to_resonance * p_born(em)) / k_res%p(0)
log_xi_max = log (xi_max)
else
E_tot2 = sqrts**2
xi_max = two * E_em / sqrts
log_xi_max = log (xi_max)
end if
associate (xi_cut => virt%settings%fks_template%xi_cut, delta_o => virt%settings%fks_template%delta_o)
if (virt%settings%virtual_resonance_aware_collinear) then
if (debug_active (D_VIRTUAL)) &
call msg_debug (D_VIRTUAL, "Using resonance-aware collinear subtraction")
s1 = virt%gamma_p(em, i_flv)
s2 = two * (log (sqrts / (two * E_em)) + log_xi_max) * &
(log (sqrts / (two * E_em)) + log_xi_max + log (virt%es_scale2 / sqrts**2)) &
* virt%c_flv(em, i_flv)
s3 = two * log_xi_max * &
(log_xi_max - log (virt%es_scale2 / E_tot2)) * virt%c_flv(em, i_flv)
s4 = (log (virt%es_scale2 / E_tot2) - two * log_xi_max) * virt%gamma_0(em, i_flv)
QB(i_flv) = QB(i_flv) + (s1 + s2 + s3 + s4) * virt%sqme_born(i_flv)
else
if (debug_active (D_VIRTUAL)) &
call msg_debug (D_VIRTUAL, "Using old-fashioned collinear subtraction")
s1 = virt%gamma_p(em, i_flv)
s2 = log (delta_o * sqrts**2 / (two * virt%es_scale2)) * virt%gamma_0(em,i_flv)
s3 = log (delta_o * sqrts**2 / (two * virt%es_scale2)) * two * virt%c_flv(em,i_flv) * &
log (two * E_em / (xi_cut * sqrts))
! s4 = two * virt%c_flv(em,i_flv) * (log (two * E_em / sqrts)**2 - log (xi_cut)**2)
s4 = two * virt%c_flv(em,i_flv) * & ! a**2 - b**2 = (a - b) * (a + b), for better numerical performance
(log (two * E_em / sqrts) + log (xi_cut)) * (log (two * E_em / sqrts) - log (xi_cut))
s5 = two * virt%gamma_0(em,i_flv) * log (two * E_em / sqrts)
QB(i_flv) = QB(i_flv) + (s1 - s2 + s3 + s4 - s5) * virt%sqme_born(i_flv)
end if
end associate
evaluated(i_flv, em) = .true.
end do
end subroutine virtual_compute_collinear_contribution
@ %def virtual_compute_collinear_contribution
@ For the massless-massive case and $i = j$ we get the massive self-eikonal of (A.10) in arXiv:0908.4272, given as
\begin{equation}
\mathcal{I}_{ii} = \log \frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{\beta} \log \frac{1 + \beta}{1 - \beta}.
\end{equation}
<<virtual: virtual: TBP>>=
procedure :: compute_massive_self_eikonals => virtual_compute_massive_self_eikonals
<<virtual: procedures>>=
subroutine virtual_compute_massive_self_eikonals (virt, i_flv, &
p_born, s_over_Q2, reg_data, QB)
class(virtual_t), intent(inout) :: virt
integer, intent(in) :: i_flv
type(vector4_t), intent(in), dimension(:) :: p_born
real(default), intent(in) :: s_over_Q2
type(region_data_t), intent(in) :: reg_data
real(default), intent(inout), dimension(:) :: QB
integer :: i
logical :: massive
do i = 1, virt%n_legs
massive = reg_data%flv_born(i_flv)%massive(i)
if (massive) then
QB(i_flv) = QB(i_flv) - (virt%c_flv (i, i_flv) &
* (log (s_over_Q2) - 0.5_default * I_m_eps (p_born(i)))) &
* virt%sqme_born (i_flv)
end if
end do
end subroutine virtual_compute_massive_self_eikonals
@ %def virtual_compute_massive_self_eikonals
@ The following code implements the $\mathcal{I}_{ij}$-function.
The complete formulas can be found in arXiv:0908.4272 (A.1-A.17).
The implementation may differ in the detail from the formulas presented in the above paper.
The parameter $\xi_{\text{cut}}$ is unphysically and cancels with appropriate factors in the real subtraction.
We keep the additional parameter for debug usage.
The implemented formulas are then defined as follows:
\begin{itemize}
\item[massless-massless case]
$p^2 = 0, k^2 = 0,$
\begin{equation}
\begin{split}
\mathcal{I}_{ij} &= \frac{1}{2}\log^2\frac{\xi^2_{\text{cut}}s}{Q^2} + \log\frac{\xi^2_{\text{cut}}s}{Q^2}\log\frac{k_ik_j}{2E_iE_j} - \rm{Li}_2\left(\frac{k_ik_j}{2E_iE_j}\right) \\
&+ \frac{1}{2}\log^2\frac{k_ik_j}{2E_iE_j} - \log\left(1-\frac{k_ik_j}{2E_iE_j}\right) \log\frac{k_ik_j}{2E_iE_j}.
\end{split}
\label{I_00}
\end{equation}
\item[massive-massive case]
$p^2 \neq 0, k^2 \neq 0,$
\begin{equation}
\mathcal{I}_{ij} = \frac{1}{2}I_0(k_i, k_j)\log\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{2}I_\epsilon(k_i,k_j)
\label{I_mm}
\end{equation}
with
\begin{equation}
I_0(k_i, k_j) = \frac{1}{\beta}\log\frac{1+\beta}{1-\beta}, \qquad \beta = \sqrt{1-\frac{k_i^2k_j^2}{(k_i \cdot k_j)^2}}
\end{equation}
and a rather involved expression for $I_\epsilon$:
\begin{align}
\allowdisplaybreaks
I_\epsilon(k_i, k_j) &= \left(K(z_j)-K(z_i)\right) \frac{1-\vec{\beta_i}\cdot\vec{\beta_j}}{\sqrt{a(1-b)}}, \\
\vec{\beta_i} &= \frac{\vec{k}_i}{k_i^0}, \\
a &= \beta_i^2 + \beta_j^2 - 2\vec{\beta}_i \cdot \vec{\beta}_j, \\
x_i &= \frac{\beta_i^2 -\vec{\beta}_i \cdot \vec{\beta}_j}{a}, \\
x_j &= \frac{\beta_j^2 -\vec{\beta}_i \cdot \vec{\beta}_j}{a} = 1-x_j, \\
b &= \frac{\beta_i^2\beta_j^2 - (\vec{\beta}_i\cdot\vec{\beta}_j)^2}{a}, \\
c &= \sqrt{\frac{b}{4a}}, \\
z_+ &= \frac{1+\sqrt{1-b}}{\sqrt{b}}, \\
z_- &= \frac{1-\sqrt{1-b}}{\sqrt{b}}, \\
z_i &= \frac{\sqrt{x_i^2 + 4c^2} - x_i}{2c}, \\
z_j &= \frac{\sqrt{x_j^2 + 4c^2} + x_j}{2c}, \\
K(z) = &-\frac{1}{2}\log^2\frac{(z-z_-)(z_+-z)}{(z_++z)(z_-+z)} - 2Li_2\left(\frac{2z_-(z_+-z)}{(z_+-z_-)(z_-+z)}\right) \\
&-2Li_2\left(-\frac{2z_+(z_-+z)}{(z_+-z_-)(z_+-z)}\right)
\end{align}
\item[massless-massive case]
$p^2 = 0, k^2 \neq 0,$
\begin{equation}
\mathcal{I}_{ij} = \frac{1}{2}\left[\log^2\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{\pi^2}{6}\right] -\frac{1}{2}I_0(k_i,k_j)\log\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{2}I_\epsilon(k_i,k_j)
\label{I_0m}
\end{equation}
with
\begin{align}
I_0(p,k) &= \log\frac{(\hat{p}\cdot\hat{k})^2}{\hat{k}^2}, \\
I_\varepsilon(p,k) &= -2\left[\frac{1}{4}\log^2\frac{1-\beta}{1+\beta} + \log\frac{\hat{p}\cdot\hat{k}}{1+\beta}\log\frac{\hat{p}\cdot\hat{k}}{1-\beta} + \rm{Li}_2\left(1-\frac{\hat{p}\cdot\hat{k}}{1+\beta}\right) + \rm{Li}_2\left(1-\frac{\hat{p}\cdot\hat{k}}{1-\beta}\right)\right],
\end{align}
using
\begin{align}
\hat{p} = \frac{p}{p^0}, \quad \hat{k} = \frac{k}{k^0}, \quad \beta = \frac{|\vec{k}|}{k_0}, \\
\rm{Li}_2(1 - x) + \rm{Li}_2(1 - x^{-1}) = -\frac{1}{2} \log^2 x.
\end{align}
\end{itemize}
<<virtual: procedures>>=
function compute_eikonal_factor (p_born, massive, i, j, s_o_Q2) result (I_ij)
real(default) :: I_ij
type(vector4_t), intent(in), dimension(:) :: p_born
logical, dimension(:), intent(in) :: massive
integer, intent(in) :: i, j
real(default), intent(in) :: s_o_Q2
if (massive(i) .and. massive(j)) then
I_ij = compute_Imm (p_born(i), p_born(j), s_o_Q2)
else if (.not. massive(i) .and. massive(j)) then
I_ij = compute_I0m (p_born(i), p_born(j), s_o_Q2)
else if (massive(i) .and. .not. massive(j)) then
I_ij = compute_I0m (p_born(j), p_born(i), s_o_Q2)
else
I_ij = compute_I00 (p_born(i), p_born(j), s_o_Q2)
end if
end function compute_eikonal_factor
function compute_I00 (pi, pj, s_o_Q2) result (I)
type(vector4_t), intent(in) :: pi, pj
real(default), intent(in) :: s_o_Q2
real(default) :: I
real(default) :: Ei, Ej
real(default) :: pij, Eij
real(default) :: s1, s2, s3, s4, s5
real(default) :: arglog
real(default), parameter :: tiny_value = epsilon(1.0)
s1 = 0; s2 = 0; s3 = 0; s4 = 0; s5 = 0
Ei = pi%p(0); Ej = pj%p(0)
pij = pi * pj; Eij = Ei * Ej
s1 = 0.5_default * log(s_o_Q2)**2
s2 = log(s_o_Q2) * log(pij / (two * Eij))
s3 = Li2 (pij / (two * Eij))
s4 = 0.5_default * log (pij / (two * Eij))**2
arglog = one - pij / (two * Eij)
if (arglog > tiny_value) then
s5 = log(arglog) * log(pij / (two * Eij))
else
s5 = zero
end if
I = s1 + s2 - s3 + s4 - s5
end function compute_I00
function compute_I0m (ki, kj, s_o_Q2) result (I)
type(vector4_t), intent(in) :: ki, kj
real(default), intent(in) :: s_o_Q2
real(default) :: I
real(default) :: logsomu
real(default) :: s1, s2, s3
s1 = 0; s2 = 0; s3 = 0
logsomu = log(s_o_Q2)
s1 = 0.5 * (0.5 * logsomu**2 - pi**2 / 6)
s2 = 0.5 * I_0m_0 (ki, kj) * logsomu
s3 = 0.5 * I_0m_eps (ki, kj)
I = s1 + s2 - s3
end function compute_I0m
function compute_Imm (pi, pj, s_o_Q2) result (I)
type(vector4_t), intent(in) :: pi, pj
real(default), intent(in) :: s_o_Q2
real(default) :: I
real(default) :: s1, s2
s1 = 0.5 * log(s_o_Q2) * I_mm_0(pi, pj)
s2 = 0.5 * I_mm_eps(pi, pj)
I = s1 - s2
end function compute_Imm
function I_m_eps (p) result (I)
type(vector4_t), intent(in) :: p
real(default) :: I
real(default) :: beta
beta = space_part_norm (p)/p%p(0)
if (beta < tiny_07) then
I = four * (one + beta**2/3 + beta**4/5 + beta**6/7)
else
I = two * log((one + beta) / (one - beta)) / beta
end if
end function I_m_eps
function I_0m_eps (p, k) result (I)
type(vector4_t), intent(in) :: p, k
real(default) :: I
type(vector4_t) :: pp, kp
real(default) :: beta
pp = p / p%p(0); kp = k / k%p(0)
beta = sqrt (one - kp*kp)
I = -2*(log((one - beta) / (one + beta))**2/4 + log((pp*kp) / (one + beta))*log((pp*kp) / (one - beta)) &
+ Li2(one - (pp*kp) / (one + beta)) + Li2(one - (pp*kp) / (one - beta)))
end function I_0m_eps
function I_0m_0 (p, k) result (I)
type(vector4_t), intent(in) :: p, k
real(default) :: I
type(vector4_t) :: pp, kp
pp = p / p%p(0); kp = k / k%p(0)
I = log((pp*kp)**2 / kp**2)
end function I_0m_0
function I_mm_eps (p1, p2) result (I)
type(vector4_t), intent(in) :: p1, p2
real(default) :: I
type(vector3_t) :: beta1, beta2
real(default) :: a, b, b2
real(default) :: zp, zm, z1, z2, x1, x2
real(default) :: zmb, z1b
real(default) :: K1, K2
beta1 = space_part (p1) / energy(p1)
beta2 = space_part (p2) / energy(p2)
a = beta1**2 + beta2**2 - 2 * beta1 * beta2
b = beta1**2 * beta2**2 - (beta1 * beta2)**2
if (beta1**1 > beta2**1) call switch_beta (beta1, beta2)
if (beta1 == vector3_null) then
b2 = beta2**1
I = (-0.5 * log ((one - b2) / (one + b2))**2 - two * Li2 (-two * b2 / (one - b2))) &
* one / sqrt (a - b)
return
end if
x1 = beta1**2 - beta1 * beta2
x2 = beta2**2 - beta1 * beta2
zp = sqrt (a) + sqrt (a - b)
zm = sqrt (a) - sqrt (a - b)
zmb = one / zp
z1 = sqrt (x1**2 + b) - x1
z2 = sqrt (x2**2 + b) + x2
z1b = one / (sqrt (x1**2 + b) + x1)
K1 = - 0.5 * log (((z1b - zmb) * (zp - z1)) / ((zp + z1) * (z1b + zmb)))**2 &
- two * Li2 ((two * zmb * (zp - z1)) / ((zp - zm) * (zmb + z1b))) &
- two * Li2 ((-two * zp * (zm + z1)) / ((zp - zm) * (zp - z1)))
K2 = - 0.5 * log ((( z2 - zm) * (zp - z2)) / ((zp + z2) * (z2 + zm)))**2 &
- two * Li2 ((two * zm * (zp - z2)) / ((zp - zm) * (zm + z2))) &
- two * Li2 ((-two * zp * (zm + z2)) / ((zp - zm) * (zp - z2)))
I = (K2 - K1) * (one - beta1 * beta2) / sqrt (a - b)
contains
subroutine switch_beta (beta1, beta2)
type(vector3_t), intent(inout) :: beta1, beta2
type(vector3_t) :: beta_tmp
beta_tmp = beta1
beta1 = beta2
beta2 = beta_tmp
end subroutine switch_beta
end function I_mm_eps
function I_mm_0 (k1, k2) result (I)
type(vector4_t), intent(in) :: k1, k2
real(default) :: I
real(default) :: beta
beta = sqrt (one - k1**2 * k2**2 / (k1 * k2)**2)
I = log ((one + beta) / (one - beta)) / beta
end function I_mm_0
@ %def I_mm_0
@
<<virtual: virtual: TBP>>=
procedure :: final => virtual_final
<<virtual: procedures>>=
subroutine virtual_final (virtual)
class(virtual_t), intent(inout) :: virtual
if (allocated (virtual%gamma_0)) deallocate (virtual%gamma_0)
if (allocated (virtual%gamma_p)) deallocate (virtual%gamma_p)
if (allocated (virtual%c_flv)) deallocate (virtual%c_flv)
if (allocated (virtual%n_is_neutrinos)) deallocate (virtual%n_is_neutrinos)
end subroutine virtual_final
@ %def virtual_final
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Real Subtraction}
<<[[real_subtraction.f90]]>>=
<<File header>>
module real_subtraction
<<Use kinds with double>>
<<Use strings>>
<<Use debug>>
use io_units
use format_defs, only: FMT_15
use string_utils
use constants
use numeric_utils
use diagnostics
use pdg_arrays
use models
use physics_defs
use sm_physics
use lorentz
use flavors
use phs_fks, only: real_kinematics_t, isr_kinematics_t
use phs_fks, only: I_PLUS, I_MINUS
use phs_fks, only: SQRTS_VAR, SQRTS_FIXED
use phs_fks, only: phs_point_set_t
use ttv_formfactors, only: m1s_to_mpole
use fks_regions
use nlo_data
<<Standard module head>>
<<real subtraction: public>>
<<real subtraction: parameters>>
<<real subtraction: types>>
<<real subtraction: interfaces>>
contains
<<real subtraction: procedures>>
end module real_subtraction
@ %def real_subtraction
@
\subsubsection{Soft subtraction terms}
<<real subtraction: parameters>>=
integer, parameter, public :: INTEGRATION = 0
integer, parameter, public :: FIXED_ORDER_EVENTS = 1
integer, parameter, public :: POWHEG = 2
@ %def real subtraction parameters
@
<<real subtraction: public>>=
public :: this_purpose
<<real subtraction: procedures>>=
function this_purpose (purpose)
type(string_t) :: this_purpose
integer, intent(in) :: purpose
select case (purpose)
case (INTEGRATION)
this_purpose = var_str ("Integration")
case (FIXED_ORDER_EVENTS)
this_purpose = var_str ("Fixed order NLO events")
case (POWHEG)
this_purpose = var_str ("Powheg events")
case default
this_purpose = var_str ("Undefined!")
end select
end function this_purpose
@ %def this_purpose
@
In the soft limit, the real matrix element behaves as
\begin{equation*}
\mathcal{R}_{\rm{soft}} = 4\pi\alpha_s \left[\sum_{i \neq j}
\mathcal{B}_{ij} \frac{k_i \cdot k_j}{(k_i \cdot k)(k_j \cdot k)}
- \mathcal{B} \sum_{i} \frac{k_i^2}{(k_i \cdot k)^2}C_i\right],
\end{equation*}
where $k$ denotes the momentum of the emitted parton. The quantity $\mathcal{B}_{ij}$ is called the color-correlated Born matrix element defined as
\begin{equation*}
\mathcal{B}_{ij} = \frac{1}{2s} \sum_{\stackrel{colors}{spins}} \mathcal{M}_{\{c_k\}}\left(\mathcal{M}^\dagger_{\{c_k\}}\right)_{\stackrel{c_i \rightarrow c_i'}{c_j \rightarrow c_j'}} T^a_{c_i,c_i'} T^a_{c_j,c_j'}.
\end{equation*}
<<real subtraction: types>>=
type :: soft_subtraction_t
type(region_data_t), pointer :: reg_data => null ()
real(default), dimension(:,:), allocatable :: momentum_matrix
logical :: use_resonance_mappings = .false.
type(vector4_t) :: p_soft = vector4_null
logical :: use_internal_color_correlations = .true.
logical :: use_internal_spin_correlations = .false.
logical :: xi2_expanded = .true.
integer :: factorization_mode = NO_FACTORIZATION
contains
<<real subtraction: soft sub: TBP>>
end type soft_subtraction_t
@ %def soft_subtraction_t
@
<<real subtraction: soft sub: TBP>>=
procedure :: init => soft_subtraction_init
<<real subtraction: procedures>>=
subroutine soft_subtraction_init (sub_soft, reg_data)
class(soft_subtraction_t), intent(inout) :: sub_soft
type(region_data_t), intent(in), target :: reg_data
sub_soft%reg_data => reg_data
allocate (sub_soft%momentum_matrix (reg_data%n_legs_born, &
reg_data%n_legs_born))
end subroutine soft_subtraction_init
@ %def soft_subtraction_init
@
<<real subtraction: soft sub: TBP>>=
procedure :: requires_boost => soft_subtraction_requires_boost
<<real subtraction: procedures>>=
function soft_subtraction_requires_boost (sub_soft, sqrts) result (requires_boost)
logical :: requires_boost
class(soft_subtraction_t), intent(in) :: sub_soft
real(default), intent(in) :: sqrts
real(default) :: mtop
logical :: above_threshold
if (sub_soft%factorization_mode == FACTORIZATION_THRESHOLD) then
mtop = m1s_to_mpole (sqrts)
above_threshold = sqrts**2 - four * mtop**2 > zero
else
above_threshold = .false.
end if
requires_boost = sub_soft%use_resonance_mappings .or. above_threshold
end function soft_subtraction_requires_boost
@ %def soft_subtraction_requires_boost
@ The treatment of the momentum $k$ follows the discussion about the
soft limit of the partition functions (ref????). The parton momentum is
pulled out, $k = E \hat{k}$. In fact, we will substitute $\hat{k}$ for
$k$ throughout the code, because the energy will factor out of the
equation when the soft $\mathcal{S}$-function is multiplied. The soft
momentum is a unit vector, because $k^2 = \left(k^0\right)^2 -
\left(k^0\right)^2\hat{\vec{k}}^2 = 0$.
The soft momentum is constructed by first creating a unit vector
parallel to the emitter's Born momentum. This unit vector is then
rotated about the corresponding angles $y$ and $\phi$.
<<real subtraction: soft sub: TBP>>=
procedure :: create_softvec_fsr => soft_subtraction_create_softvec_fsr
<<real subtraction: procedures>>=
subroutine soft_subtraction_create_softvec_fsr &
(sub_soft, p_born, y, phi, emitter, xi_ref_momentum)
class(soft_subtraction_t), intent(inout) :: sub_soft
type(vector4_t), intent(in), dimension(:) :: p_born
real(default), intent(in) :: y, phi
integer, intent(in) :: emitter
type(vector4_t), intent(in) :: xi_ref_momentum
type(vector3_t) :: dir
type(vector4_t) :: p_em
type(lorentz_transformation_t) :: rot
type(lorentz_transformation_t) :: boost_to_rest_frame
logical :: requires_boost
associate (p_soft => sub_soft%p_soft)
p_soft%p(0) = one
requires_boost = sub_soft%requires_boost (two * p_born(1)%p(0))
if (requires_boost) then
boost_to_rest_frame = inverse (boost (xi_ref_momentum, xi_ref_momentum**1))
p_em = boost_to_rest_frame * p_born(emitter)
else
p_em = p_born(emitter)
end if
p_soft%p(1:3) = p_em%p(1:3) / space_part_norm (p_em)
dir = create_orthogonal (space_part (p_em))
rot = rotation (y, sqrt(one - y**2), dir)
p_soft = rot * p_soft
if (.not. vanishes (phi)) then
dir = space_part (p_em) / space_part_norm (p_em)
rot = rotation (cos(phi), sin(phi), dir)
p_soft = rot * p_soft
end if
if (requires_boost) p_soft = inverse (boost_to_rest_frame) * p_soft
end associate
end subroutine soft_subtraction_create_softvec_fsr
@ %def soft_subtraction_create_softvec_fsr
@ For initial-state emissions, the soft vector is just a unit vector
with the same direction as the radiated particle.
<<real subtraction: soft sub: TBP>>=
procedure :: create_softvec_isr => soft_subtraction_create_softvec_isr
<<real subtraction: procedures>>=
subroutine soft_subtraction_create_softvec_isr (sub_soft, y, phi)
class(soft_subtraction_t), intent(inout) :: sub_soft
real(default), intent(in) :: y, phi
real(default) :: sin_theta
sin_theta = sqrt(one - y**2)
associate (p => sub_soft%p_soft%p)
p(0) = one
p(1) = sin_theta * sin(phi)
p(2) = sin_theta * cos(phi)
p(3) = y
end associate
end subroutine soft_subtraction_create_softvec_isr
@ %def soft_subtraction_create_softvec_isr
@ The soft vector for the real mismatch is basically the same as for usual FSR,
except for the scaling with the total gluon energy. Moreover, the resulting
vector is rotated into the frame where the 3-axis points along the direction
of the emitter. This is necessary because in the collinear limit, the approximation
\begin{equation*}
k_i = \frac{k_i^0}{\bar{k}_j^0} \bar{k}_j = \frac{\xi\sqrt{s}}{2\bar{k}_j^0}\bar{k}_j
\end{equation*}
is used. The collinear limit is not included in the soft mismatch yet, but we keep
the rotation for future usage here already (the performance loss is negligible).
<<real subtraction: soft sub: TBP>>=
procedure :: create_softvec_mismatch => &
soft_subtraction_create_softvec_mismatch
<<real subtraction: procedures>>=
subroutine soft_subtraction_create_softvec_mismatch (sub_soft, E, y, phi, p_em)
class(soft_subtraction_t), intent(inout) :: sub_soft
real(default), intent(in) :: E, phi, y
type(vector4_t), intent(in) :: p_em
real(default) :: sin_theta
type(lorentz_transformation_t) :: rot_em_off_3_axis
sin_theta = sqrt (one - y**2)
associate (p => sub_soft%p_soft%p)
p(0) = E
p(1) = E * sin_theta * sin(phi)
p(2) = E * sin_theta * cos(phi)
p(3) = E * y
end associate
rot_em_off_3_axis = rotation_to_2nd (3, space_part (p_em))
sub_soft%p_soft = rot_em_off_3_axis * sub_soft%p_soft
end subroutine soft_subtraction_create_softvec_mismatch
@ %def soft_subtraction_create_softvec_mismatch
@ Computation of the soft limit of $R_\alpha$. Note that what we are
actually integrating (in the case of final-state radiation) is the
quantity $f(0,y) / \xi$, where
\begin{equation*}
f(\xi,y) = \frac{J(\xi,y,\phi)}{\xi} \xi^2 R_\alpha.
\end{equation*}
$J/\xi$ is computed by the phase space generator. The additional factor
of $\xi^{-1}$ is supplied in the [[evaluate_region_fsr]]-routine. Thus,
we are left with a factor of $\xi^2$. A look on the expression for the
soft limit of $R_\alpha$ below reveals that we are factoring out the gluon
energy $E_i$ in the denominator. Therefore, we have a factor
$\xi^2 / E_i^2 = q^2 / 4$.\\
Note that the same routine is used also for the computation of the soft
mismatch. There, the gluon energy is not factored out from the soft vector,
so that we are left with the $\xi^2$-factor, which will eventually be
cancelled out again. So, we just multiply with 1. Both cases are
distinguished by the flag [[xi2_expanded]].
<<real subtraction: soft sub: TBP>>=
procedure :: compute => soft_subtraction_compute
<<real subtraction: procedures>>=
function soft_subtraction_compute (sub_soft, p_born, &
born_ij, y, q2, alpha_coupling, alr, emitter, i_res) result (sqme)
real(default) :: sqme
class(soft_subtraction_t), intent(inout) :: sub_soft
type(vector4_t), intent(in), dimension(:) :: p_born
real(default), intent(in), dimension(:,:) :: born_ij
real(default), intent(in) :: y
real(default), intent(in) :: q2, alpha_coupling
integer, intent(in) :: alr, emitter, i_res
real(default) :: s_alpha_soft
real(default) :: kb
real(default) :: xi2_factor
if (.not. vector_set_is_cms (p_born, sub_soft%reg_data%n_in)) then
call vector4_write_set (p_born, show_mass = .true., &
check_conservation = .true.)
call msg_fatal ("Soft subtraction: phase space point must be in CMS")
end if
if (debug2_active (D_SUBTRACTION)) then
associate (nlo_corr_type => sub_soft%reg_data%regions(alr)%nlo_correction_type)
if (nlo_corr_type == "QCD") then
print *, 'Compute soft subtraction using alpha_s = ', alpha_coupling
else if (nlo_corr_type == "QED") then
print *, 'Compute soft subtraction using alpha_qed = ', alpha_coupling
end if
end associate
end if
s_alpha_soft = sub_soft%reg_data%get_svalue_soft (p_born, &
sub_soft%p_soft, alr, emitter, i_res)
if (s_alpha_soft > one + tiny_07) call msg_fatal ("s_alpha_soft > 1!")
if (debug2_active (D_SUBTRACTION)) &
call msg_print_color ('s_alpha_soft', s_alpha_soft, COL_YELLOW)
select case (sub_soft%factorization_mode)
case (NO_FACTORIZATION)
kb = sub_soft%evaluate_factorization_default (p_born, born_ij)
case (FACTORIZATION_THRESHOLD)
kb = sub_soft%evaluate_factorization_threshold (thr_leg(emitter), p_born, born_ij)
end select
if (debug_on) call msg_debug2 (D_SUBTRACTION, 'KB', kb)
sqme = four * pi * alpha_coupling * s_alpha_soft * kb
if (sub_soft%xi2_expanded) then
xi2_factor = four / q2
else
xi2_factor = one
end if
if (emitter <= sub_soft%reg_data%n_in) then
sqme = xi2_factor * (one - y**2) * sqme
else
sqme = xi2_factor * (one - y) * sqme
end if
end function soft_subtraction_compute
@ %def soft_subtraction_compute
@ We loop over all external legs and do not take care to leave out non-colored
ones because [[born_ij]] is constructed in such a way that it is only
non-zero for colored entries.
<<real subtraction: soft sub: TBP>>=
procedure :: evaluate_factorization_default => &
soft_subtraction_evaluate_factorization_default
<<real subtraction: procedures>>=
function soft_subtraction_evaluate_factorization_default &
(sub_soft, p, born_ij) result (kb)
real(default) :: kb
class(soft_subtraction_t), intent(inout) :: sub_soft
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in), dimension(:,:) :: born_ij
integer :: i, j
kb = zero
call sub_soft%compute_momentum_matrix (p)
do i = 1, size (p)
do j = 1, size (p)
kb = kb + sub_soft%momentum_matrix (i, j) * born_ij (i, j)
end do
end do
end function soft_subtraction_evaluate_factorization_default
@ %def soft_subtraction_evaluate_factorization_default
@ We have to multiply this with $\xi^2(1-y)$. Further, when applying
the soft $\mathcal{S}$-function, the energy of the radiated particle
is factored out. Thus we have $\xi^2/E_{em}^2(1-y) = 4/q_0^2(1-y)$.
Computes the quantity $\mathcal{K}_{ij} = \frac{k_i \cdot
k_j}{(k_i\cdot k)(k_j\cdot k)}$.
<<real subtraction: soft sub: TBP>>=
procedure :: compute_momentum_matrix => &
soft_subtraction_compute_momentum_matrix
<<real subtraction: procedures>>=
subroutine soft_subtraction_compute_momentum_matrix &
(sub_soft, p_born)
class(soft_subtraction_t), intent(inout) :: sub_soft
type(vector4_t), intent(in), dimension(:) :: p_born
real(default) :: num, deno1, deno2
integer :: i, j
do i = 1, sub_soft%reg_data%n_legs_born
do j = 1, sub_soft%reg_data%n_legs_born
if (i <= j) then
num = p_born(i) * p_born(j)
deno1 = p_born(i) * sub_soft%p_soft
deno2 = p_born(j) * sub_soft%p_soft
sub_soft%momentum_matrix(i, j) = num / (deno1 * deno2)
else
!!! momentum matrix is symmetric.
sub_soft%momentum_matrix(i, j) = sub_soft%momentum_matrix(j, i)
end if
end do
end do
end subroutine soft_subtraction_compute_momentum_matrix
@ %def soft_subtraction_compute_momentum_matrx
@
<<real subtraction: soft sub: TBP>>=
procedure :: evaluate_factorization_threshold => &
soft_subtraction_evaluate_factorization_threshold
<<real subtraction: procedures>>=
function soft_subtraction_evaluate_factorization_threshold &
(sub_soft, leg, p_born, born_ij) result (kb)
real(default) :: kb
class(soft_subtraction_t), intent(inout) :: sub_soft
integer, intent(in) :: leg
type(vector4_t), intent(in), dimension(:) :: p_born
real(default), intent(in), dimension(:,:) :: born_ij
type(vector4_t), dimension(4) :: p
p = get_threshold_momenta (p_born)
kb = evaluate_leg_pair (ASSOCIATED_LEG_PAIR (leg))
if (debug2_active (D_SUBTRACTION)) call show_debug ()
contains
function evaluate_leg_pair (i_start) result (kbb)
real(default) :: kbb
integer, intent(in) :: i_start
integer :: i1, i2
real(default) :: numerator, deno1, deno2
kbb = zero
do i1 = i_start, i_start + 1
do i2 = i_start, i_start + 1
numerator = p(i1) * p(i2)
deno1 = p(i1) * sub_soft%p_soft
deno2 = p(i2) * sub_soft%p_soft
kbb = kbb + numerator * born_ij (i1, i2) / deno1 / deno2
end do
end do
if (debug2_active (D_SUBTRACTION)) then
do i1 = i_start, i_start + 1
do i2 = i_start, i_start + 1
call msg_print_color('i1', i1, COL_PEACH)
call msg_print_color('i2', i2, COL_PEACH)
call msg_print_color('born_ij (i1,i2)', born_ij (i1,i2), COL_PINK)
print *, 'Top momentum: ', p(1)%p
end do
end do
end if
end function evaluate_leg_pair
subroutine show_debug ()
integer :: i
call msg_print_color ('soft_subtraction_evaluate_factorization_threshold', COL_GREEN)
do i = 1, 4
print *, 'sqrt(p(i)**2) = ', sqrt(p(i)**2)
end do
end subroutine show_debug
end function soft_subtraction_evaluate_factorization_threshold
@ %def soft_subtraction_evaluate_factorization_threshold
@
<<real subtraction: soft sub: TBP>>=
procedure :: i_xi_ref => soft_subtraction_i_xi_ref
<<real subtraction: procedures>>=
function soft_subtraction_i_xi_ref (sub_soft, alr, i_phs) result (i_xi_ref)
integer :: i_xi_ref
class(soft_subtraction_t), intent(in) :: sub_soft
integer, intent(in) :: alr, i_phs
if (sub_soft%use_resonance_mappings) then
i_xi_ref = sub_soft%reg_data%alr_to_i_contributor (alr)
else if (sub_soft%factorization_mode == FACTORIZATION_THRESHOLD) then
i_xi_ref = i_phs
else
i_xi_ref = 1
end if
end function soft_subtraction_i_xi_ref
@ %def soft_subtraction_i_xi_ref
@
<<real subtraction: soft sub: TBP>>=
procedure :: final => soft_subtraction_final
<<real subtraction: procedures>>=
subroutine soft_subtraction_final (sub_soft)
class(soft_subtraction_t), intent(inout) :: sub_soft
if (associated (sub_soft%reg_data)) nullify (sub_soft%reg_data)
if (allocated (sub_soft%momentum_matrix)) deallocate (sub_soft%momentum_matrix)
end subroutine soft_subtraction_final
@ %def soft_subtraction_final
@
\subsection{Soft mismatch}
<<real subtraction: public>>=
public :: soft_mismatch_t
<<real subtraction: types>>=
type :: soft_mismatch_t
type(region_data_t), pointer :: reg_data => null ()
real(default), dimension(:), allocatable :: sqme_born
real(default), dimension(:,:,:), allocatable :: sqme_born_color_c
real(default), dimension(:,:,:), allocatable :: sqme_born_charge_c
type(real_kinematics_t), pointer :: real_kinematics => null ()
type(soft_subtraction_t) :: sub_soft
contains
<<real subtraction: soft mismatch: TBP>>
end type soft_mismatch_t
@ %def soft_mismatch_t
@
<<real subtraction: soft mismatch: TBP>>=
procedure :: init => soft_mismatch_init
<<real subtraction: procedures>>=
subroutine soft_mismatch_init (soft_mismatch, reg_data, &
real_kinematics, factorization_mode)
class(soft_mismatch_t), intent(inout) :: soft_mismatch
type(region_data_t), intent(in), target :: reg_data
type(real_kinematics_t), intent(in), target :: real_kinematics
integer, intent(in) :: factorization_mode
soft_mismatch%reg_data => reg_data
allocate (soft_mismatch%sqme_born (reg_data%n_flv_born))
allocate (soft_mismatch%sqme_born_color_c (reg_data%n_legs_born, &
reg_data%n_legs_born, reg_data%n_flv_born))
allocate (soft_mismatch%sqme_born_charge_c (reg_data%n_legs_born, &
reg_data%n_legs_born, reg_data%n_flv_born))
call soft_mismatch%sub_soft%init (reg_data)
soft_mismatch%sub_soft%xi2_expanded = .false.
soft_mismatch%real_kinematics => real_kinematics
soft_mismatch%sub_soft%factorization_mode = factorization_mode
end subroutine soft_mismatch_init
@ %def soft_mismatch_init
@ Main routine to compute the soft mismatch. Loops over all singular regions.
There, it first creates the soft vector, then the necessary soft real matrix element.
These inputs are then used to get the numerical value of the soft mismatch.
<<real subtraction: soft mismatch: TBP>>=
procedure :: evaluate => soft_mismatch_evaluate
<<real subtraction: procedures>>=
function soft_mismatch_evaluate (soft_mismatch, alpha_s) result (sqme_mismatch)
real(default) :: sqme_mismatch
class(soft_mismatch_t), intent(inout) :: soft_mismatch
real(default), intent(in) :: alpha_s
integer :: alr, i_born, emitter, i_res, i_phs, i_con
real(default) :: xi, y, q2, s
real(default) :: E_gluon
type(vector4_t) :: p_em
real(default) :: sqme_alr, sqme_soft
type(vector4_t), dimension(:), allocatable :: p_born
sqme_mismatch = zero
associate (real_kinematics => soft_mismatch%real_kinematics)
xi = real_kinematics%xi_mismatch
y = real_kinematics%y_mismatch
s = real_kinematics%cms_energy2
E_gluon = sqrt (s) * xi / two
if (debug_active (D_MISMATCH)) then
print *, 'Evaluating soft mismatch: '
print *, 'Phase space: '
call vector4_write_set (real_kinematics%p_born_cms%get_momenta(1), &
show_mass = .true.)
print *, 'xi: ', xi, 'y: ', y, 's: ', s, 'E_gluon: ', E_gluon
end if
allocate (p_born (soft_mismatch%reg_data%n_legs_born))
do alr = 1, soft_mismatch%reg_data%n_regions
i_phs = real_kinematics%alr_to_i_phs (alr)
if (soft_mismatch%reg_data%has_pseudo_isr ()) then
i_con = 1
p_born = soft_mismatch%real_kinematics%p_born_onshell%get_momenta(1)
else
i_con = soft_mismatch%reg_data%alr_to_i_contributor (alr)
p_born = soft_mismatch%real_kinematics%p_born_cms%get_momenta(1)
end if
q2 = real_kinematics%xi_ref_momenta(i_con)**2
emitter = soft_mismatch%reg_data%regions(alr)%emitter
p_em = p_born (emitter)
i_res = soft_mismatch%reg_data%regions(alr)%i_res
i_born = soft_mismatch%reg_data%regions(alr)%uborn_index
call print_debug_alr ()
call soft_mismatch%sub_soft%create_softvec_mismatch &
(E_gluon, y, real_kinematics%phi, p_em)
if (debug_active (D_MISMATCH)) &
print *, 'Created soft vector: ', soft_mismatch%sub_soft%p_soft%p
select type (fks_mapping => soft_mismatch%reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
call fks_mapping%set_resonance_momentum &
(real_kinematics%xi_ref_momenta(i_con))
end select
sqme_soft = soft_mismatch%sub_soft%compute &
(p_born, soft_mismatch%sqme_born_color_c(:,:,i_born), y, &
q2, alpha_s, alr, emitter, i_res)
sqme_alr = soft_mismatch%compute (alr, xi, y, p_em, &
real_kinematics%xi_ref_momenta(i_con), soft_mismatch%sub_soft%p_soft, &
soft_mismatch%sqme_born(i_born), sqme_soft, &
alpha_s, s)
if (debug_on) call msg_debug (D_MISMATCH, 'sqme_alr: ', sqme_alr)
sqme_mismatch = sqme_mismatch + sqme_alr
end do
end associate
contains
subroutine print_debug_alr ()
if (debug_active (D_MISMATCH)) then
print *, 'alr: ', alr
print *, 'i_phs: ', i_phs, 'i_con: ', i_con, 'i_res: ', i_res
print *, 'emitter: ', emitter, 'i_born: ', i_born
print *, 'emitter momentum: ', p_em%p
print *, 'resonance momentum: ', &
soft_mismatch%real_kinematics%xi_ref_momenta(i_con)%p
print *, 'q2: ', q2
end if
end subroutine print_debug_alr
end function soft_mismatch_evaluate
@ %def soft_mismatch_evaluate
@ Computes the soft mismatch in a given $\alpha_r$,
\begin{align*}
I_{s+,\alpha_r} &= \int d\Phi_B \int_0^\infty d\xi \int_{-1}^1 dy \int_0^{2\pi} d\phi
\frac{s\xi}{(4\pi)^3} \\
&\times \left\lbrace\tilde{R}_{\alpha_r}
\left(e^{-\frac{2k_\gamma \cdot k_{res}}{k_{res}}^2} - e^{-\xi}\right)
- \frac{32 \pi \alpha_s C_{em}}{s\xi^2} B_{f_b(\alpha_r)} (1-y)^{-1}
\left[e^{-\frac{2\bar{k}_{em} \cdot k_{res}}{k_{res}^2} \frac{k_\gamma^0}{k_{em}^0}} - e^{-\xi}\right]\right\rbrace.
\end{align*}
<<real subtraction: soft mismatch: TBP>>=
procedure :: compute => soft_mismatch_compute
<<real subtraction: procedures>>=
function soft_mismatch_compute (soft_mismatch, alr, xi, y, p_em, p_res, p_soft, &
sqme_born, sqme_soft, alpha_s, s) result (sqme_mismatch)
real(default) :: sqme_mismatch
class(soft_mismatch_t), intent(in) :: soft_mismatch
integer, intent(in) :: alr
real(default), intent(in) :: xi, y
type(vector4_t), intent(in) :: p_em, p_res, p_soft
real(default), intent(in) :: sqme_born, sqme_soft
real(default), intent(in) :: alpha_s, s
real(default) :: q2, expo, sm1, sm2, jacobian
q2 = p_res**2
expo = - two * p_soft * p_res / q2
!!! Divide by 1 - y to factor out the corresponding
!!! factor in the soft matrix element
sm1 = sqme_soft / (one - y) * ( exp(expo) - exp(- xi) )
if (debug_on) call msg_debug2 (D_MISMATCH, 'sqme_soft in mismatch ', sqme_soft)
sm2 = zero
if (soft_mismatch%reg_data%regions(alr)%has_collinear_divergence ()) then
expo = - two * p_em * p_res / q2 * &
p_soft%p(0) / p_em%p(0)
sm2 = 32 * pi * alpha_s * cf / (s * xi**2) * sqme_born * &
( exp(expo) - exp(- xi) ) / (one - y)
end if
jacobian = soft_mismatch%real_kinematics%jac_mismatch * s * xi / (8 * twopi3)
sqme_mismatch = (sm1 - sm2) * jacobian
end function soft_mismatch_compute
@ %def soft_mismatch_compute
@
<<real subtraction: soft mismatch: TBP>>=
procedure :: final => soft_mismatch_final
<<real subtraction: procedures>>=
subroutine soft_mismatch_final (soft_mismatch)
class(soft_mismatch_t), intent(inout) :: soft_mismatch
call soft_mismatch%sub_soft%final ()
if (associated (soft_mismatch%reg_data)) nullify (soft_mismatch%reg_data)
if (allocated (soft_mismatch%sqme_born)) deallocate (soft_mismatch%sqme_born)
if (allocated (soft_mismatch%sqme_born_color_c)) deallocate (soft_mismatch%sqme_born_color_c)
if (allocated (soft_mismatch%sqme_born_charge_c)) deallocate (soft_mismatch%sqme_born_charge_c)
if (associated (soft_mismatch%real_kinematics)) nullify (soft_mismatch%real_kinematics)
end subroutine soft_mismatch_final
@ %def soft_mismatch_final
@
\subsection{Collinear and soft-collinear subtraction terms}
This data type deals with the calculation of the collinear and
soft-collinear contribution to the cross section.
<<real subtraction: public>>=
public :: coll_subtraction_t
<<real subtraction: types>>=
type :: coll_subtraction_t
integer :: n_in, n_alr
logical :: use_resonance_mappings = .false.
real(default) :: CA = 0, CF = 0, TR = 0
contains
<<real subtraction: coll sub: TBP>>
end type coll_subtraction_t
@ %def coll_subtraction_t
@
<<real subtraction: coll sub: TBP>>=
procedure :: init => coll_subtraction_init
<<real subtraction: procedures>>=
subroutine coll_subtraction_init (coll_sub, n_alr, n_in)
class(coll_subtraction_t), intent(inout) :: coll_sub
integer, intent(in) :: n_alr, n_in
coll_sub%n_in = n_in
coll_sub%n_alr = n_alr
end subroutine coll_subtraction_init
@ %def coll_subtraction_init
@ Set the corresponding algebra parameters of the underlying gauge group of the correction.
<<real subtraction: coll sub: TBP>>=
procedure :: set_parameters => coll_subtraction_set_parameters
<<real subtraction: procedures>>=
subroutine coll_subtraction_set_parameters (coll_sub, CA, CF, TR)
class(coll_subtraction_t), intent(inout) :: coll_sub
real(default), intent(in) :: CA, CF, TR
coll_sub%CA = CA
coll_sub%CF = CF
coll_sub%TR = TR
end subroutine coll_subtraction_set_parameters
@ %def coll_subtraction_set_parameters
@ This subroutine computes the collinear limit of $g^\alpha(\xi,y)$ introduced
in eq.~\ref{fks: sub: real}. Care is given to also enable the usage for
the soft-collinear limit. This, we write all formulas in terms of soft-finite
quantities.
We have to compute
\begin{equation*}
\frac{J(\Phi_n,\xi,y,\phi)}{\xi} \left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]|_{y = 1}.
\end{equation*}
The Jacobian $j$ is proportional to $\xi$, due to the $d^3 k_{n+1} / k_{n+1}^0$ factor
in the integration measure. It cancels the factor of $\xi$ in the denominator.
The remaining part of the Jacobian is multiplied in [[evaluate_region_fsr]] and is
not relevant here.
Inserting the splitting functions exemplarily for $q \to qg$ yields
\begin{equation*}
g^\alpha = \frac{8\pi\alpha_s}{k_{\mathrm{em}}^2} C_F (1-y) \xi^2
\frac{1+(1-z)^2}{z} \mathcal{B},
\end{equation*}
where we have chosen $z = E_\mathrm{rad} / \bar{E}_\mathrm{em}$ and $\bar{E}_\mathrm{em}$ denotes the emitter energy in the Born frame.
The collinear final state imposes $\bar{k}_n = k_{n} + k_{k + 1}$ for the
connection between $\Phi_n$- and $\Phi_{n+1}$-phasepace and we get $1 - z = E_\mathrm{em} / \bar{E}_\mathrm{em}$.
The denominator can be rewritten by the constraint $\bar{k}_n^2 = (k_n +
k_{n+1})^2 = 0$ to
\begin{equation*}
k_{\mathrm{em}}^2 = 2 E_\mathrm{rad} E_\mathrm{em} (1-y)
\end{equation*}
which cancels the $(1-y)$ factor in the numerator, thus showing that
the whole expression is indeed collinear-finite. We can further transform
\begin{equation*}
E_\mathrm{rad} E_\mathrm{em} = z (1-z) \bar{E}_\mathrm{em}^2
\end{equation*}
so that in total we have
\begin{equation*}
g^\alpha = \frac{4\pi\alpha_s}{1-z} \frac{1}{\bar{k}_{\text{em}}^2} C_F \left(\frac{\xi}{z}\right)^2
(1 + (1-z)^2) \mathcal{B}
\end{equation*}
Follow up calculations give us
\begin{align*}
g^{\alpha, g \rightarrow gg} & = \frac{4\pi\alpha_s}{1-z}\frac{1}{\bar{k}_{\text{em}}^2}
C_{\mathrm{A}} \frac{\xi}{z} \left\lbrace 2 \left( \frac{z}{1 - z} \xi + \frac{1 - z}{\frac{z}{\xi}} \right) \mathcal{B} + 4\xi z(1 - z) \hat{k}_{\perp}^{\mu} \hat{k}_{\perp}^{\nu} \mathcal{B}_{\mu\nu} \right\rbrace, \\
g^{\alpha, g \rightarrow qq} & = \frac{4\pi\alpha_s}{1-z} \frac{1}{\bar{k}_{\text{em}}^2} T_{\mathrm{R}}
\frac{\xi}{z} \left\lbrace \xi \mathcal{B} - 4\xi z(1 - z) \hat{k}_{\perp}^{\mu} \hat{k}_{\perp}^{\nu} \mathcal{B}_{\mu\nu} \right\rbrace.
\end{align*}
The ratio $z / \xi$ is finite in the soft limit
\begin{equation*}
\frac{z}{\xi} = \frac{q^0}{2\bar{E}_\mathrm{em}}
\end{equation*}
so that $\xi$ does not appear explicitly in the computation.
The argumentation above is valid for $q \to qg$--splittings, but the general
factorization is valid for general splittings, also for those involving spin
correlations and QED splittings. Note that care has to be given to the definition
of $z$. Further, we have factored out a factor of $z$ to include in the
ratio $z/\xi$, which has to be taken into account in the implementation of
the splitting functions.
<<real subtraction: coll sub: TBP>>=
procedure :: compute_fsr => coll_subtraction_compute_fsr
<<real subtraction: procedures>>=
function coll_subtraction_compute_fsr &
(coll_sub, emitter, flst, p_res, p_born, sqme_born, mom_times_sqme_spin_c, &
xi, alpha_coupling, double_fsr) result (sqme)
real(default) :: sqme
class(coll_subtraction_t), intent(in) :: coll_sub
integer, intent(in) :: emitter
integer, dimension(:), intent(in) :: flst
type(vector4_t), intent(in) :: p_res
type(vector4_t), intent(in), dimension(:) :: p_born
real(default), intent(in) :: sqme_born, mom_times_sqme_spin_c
real(default), intent(in) :: xi, alpha_coupling
logical, intent(in) :: double_fsr
real(default) :: q0, z, p0, z_o_xi, onemz
integer :: nlegs, flv_em, flv_rad
nlegs = size (flst)
flv_rad = flst(nlegs); flv_em = flst(emitter)
q0 = p_res**1
p0 = p_res * p_born(emitter) / q0
!!! Here, z corresponds to 1-z in the formulas of arXiv:1002.2581;
!!! the integrand is symmetric under this variable change
z_o_xi = q0 / (two * p0)
z = xi * z_o_xi; onemz = one - z
if (is_gluon (flv_em) .and. is_gluon (flv_rad)) then
sqme = coll_sub%CA * ( two * ( z / onemz * xi + onemz / z_o_xi ) * sqme_born &
+ four * xi * z * onemz * mom_times_sqme_spin_c )
else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then
sqme = coll_sub%TR * xi * (sqme_born - four * z * onemz * mom_times_sqme_spin_c)
else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then
sqme = sqme_born * coll_sub%CF * (one + onemz**2) / z_o_xi
else
sqme = zero
end if
sqme = sqme / (p0**2 * onemz * z_o_xi)
sqme = sqme * four * pi * alpha_coupling
if (double_fsr) sqme = sqme * onemz
end function coll_subtraction_compute_fsr
@ %def coll_subtraction_compute_fsr
@ Like in the context of [[coll_subtraction_compute_fsr]] we compute
the quantity
\begin{equation*}
\frac{J(\Phi_n,\xi,y,\phi)}{\xi} \left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]|_{y = 1},
\end{equation*}
and, additionally the anti-collinear case with $y = +1$, which, however,
is completely analogous. Again, the Jacobian is proportional to $\xi$, so we
drop the $J / \xi$ factor. Note that it is important to take into account this missing
factor of $\xi$ in the computation of the Jacobian during phase-space generation
both for fixed-beam and structure ISR. We consider only a $q \to qg$ splitting
arguing that other splittings are identical in terms of the
factors which cancel. It is given by
\begin{equation*}
g^\alpha = \frac{8\pi\alpha_s}{-k_{\mathrm{em}}^2} C_F (1-y) \xi^2
\frac{1+z^2}{1-z} \mathcal{B}.
\end{equation*}
Note the negative sign of $k_\mathrm{em}^2$ to compensate the negative
virtuality of the initial-state emitter.
For ISR, $z$ is defined with respect to the emitter energy entering the hard
interaction, i.e.
\begin{equation*}
z = \frac{E_\mathrm{beam} - E_\mathrm{rad}}{E_\mathrm{beam}} =
1 - \frac{E_\mathrm{rad}}{E_\mathrm{beam}}.
\end{equation*}
Because $E_\mathrm{rad} = E_\mathrm{beam} \cdot \xi$, it is
$z = 1 - \xi$. The factor $k_\mathrm{em}^2$ in the denonimator
is rewritten as
\begin{equation*}
k_\mathrm{em}^2 = \left(p_\mathrm{beam} - p_\mathrm{rad}\right)^2
= - 2 p_\mathrm{beam} \cdot p_\mathrm{rad}
= - 2 E_\mathrm{beam} E_\mathrm{rad} (1-y)
= -2 E_\mathrm{beam}^2 (1-z) (1-y).
\end{equation*}
This leads to the cancellation of the $(1-y)$ factors and one of
the two factors of $\xi$ in the numerator. Further rewriting to
\begin{equation*}
E_\mathrm{beam} E_\mathrm{rad} = E_\mathrm{beam}^2 (1-z)
\end{equation*}
cancels another factor of $\xi$. We thus end up with
\begin{equation*}
g^\alpha = \frac{4\pi\alpha_s}{E_\mathrm{beam}^2} C_F \left(1 + z^2\right)\mathcal{B},
\end{equation*}
which is soft-finite.
Now what about this boosting to the other beam?
<<real subtraction: coll sub: TBP>>=
procedure :: compute_isr => coll_subtraction_compute_isr
<<real subtraction: procedures>>=
function coll_subtraction_compute_isr &
(coll_sub, emitter, flst, p_born, sqme_born, mom_times_sqme_spin_c, &
xi, alpha_coupling, isr_mode) result (sqme)
real(default) :: sqme
class(coll_subtraction_t), intent(in) :: coll_sub
integer, intent(in) :: emitter
integer, dimension(:), intent(in) :: flst
type(vector4_t), intent(in), dimension(:) :: p_born
real(default), intent(in) :: sqme_born
real(default), intent(in) :: mom_times_sqme_spin_c
real(default), intent(in) :: xi, alpha_coupling
integer, intent(in) :: isr_mode
real(default) :: z, onemz, p02
integer :: nlegs, flv_em, flv_rad
if (isr_mode == SQRTS_VAR .and. vector_set_is_cms (p_born, coll_sub%n_in)) then
call vector4_write_set (p_born, show_mass = .true., &
check_conservation = .true.)
call msg_fatal ("Collinear subtraction, ISR: Phase space point &
&must be in lab frame")
end if
nlegs = size (flst)
flv_rad = flst(nlegs); flv_em = flst(emitter)
!!! No need to pay attention to n_in = 1, because this case always has a
!!! massive initial-state particle and thus no collinear divergence.
p02 = p_born(1)%p(0) * p_born(2)%p(0) / two
z = one - xi; onemz = xi
if (is_massless_vector (flv_em) .and. is_massless_vector (flv_rad)) then
sqme = coll_sub%CA * (two * (z + z * onemz**2) * sqme_born + four * onemz**2 &
/ z * mom_times_sqme_spin_c)
else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then
sqme = coll_sub%CF * (one + z**2) * sqme_born
else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then
sqme = coll_sub%CF * (z * onemz * sqme_born + four * onemz**2 / z * mom_times_sqme_spin_c)
else if (is_massless_vector (flv_em) .and. is_fermion (flv_rad)) then
sqme = coll_sub%TR * (z**2 + onemz**2) * onemz * sqme_born
else
sqme = zero
end if
if (isr_mode == SQRTS_VAR) then
sqme = sqme / p02 * z
else
!!! We have no idea why this seems to work as there should be no factor
!!! of z for the fixed-beam settings. This should definitely be understood in the
!!! future!
sqme = sqme / p02 / z
end if
sqme = sqme * four * pi * alpha_coupling
end function coll_subtraction_compute_isr
@ %def coll_subtraction_compute_isr
@
<<real subtraction: coll sub: TBP>>=
procedure :: final => coll_subtraction_final
<<real subtraction: procedures>>=
subroutine coll_subtraction_final (sub_coll)
class(coll_subtraction_t), intent(inout) :: sub_coll
sub_coll%use_resonance_mappings = .false.
end subroutine coll_subtraction_final
@ %def coll_subtraction_final
@
\subsection{Real Subtraction}
We store a pointer to the [[nlo_settings_t]] object which holds tuning parameters, e.g. cutoffs for the subtraction terms.
<<real subtraction: public>>=
public :: real_subtraction_t
<<real subtraction: types>>=
type :: real_subtraction_t
type(nlo_settings_t), pointer :: settings => null ()
type(region_data_t), pointer :: reg_data => null ()
type(real_kinematics_t), pointer :: real_kinematics => null ()
type(isr_kinematics_t), pointer :: isr_kinematics => null ()
type(real_scales_t) :: scales
real(default), dimension(:,:), allocatable :: sqme_real_non_sub
real(default), dimension(:), allocatable :: sqme_born
real(default), dimension(:,:,:), allocatable :: sqme_coll_isr
real(default), dimension(:,:,:), allocatable :: sqme_born_color_c
real(default), dimension(:,:,:), allocatable :: sqme_born_charge_c
complex(default), dimension(:,:,:,:), allocatable :: sqme_born_spin_c
type(soft_subtraction_t) :: sub_soft
type(coll_subtraction_t) :: sub_coll
logical, dimension(:), allocatable :: sc_required
logical :: subtraction_deactivated = .false.
integer :: purpose = INTEGRATION
logical :: radiation_event = .true.
logical :: subtraction_event = .false.
integer, dimension(:), allocatable :: selected_alr
contains
<<real subtraction: real subtraction: TBP>>
end type real_subtraction_t
@ %def real_subtraction_t
@ Initializer
<<real subtraction: real subtraction: TBP>>=
procedure :: init => real_subtraction_init
<<real subtraction: procedures>>=
subroutine real_subtraction_init (rsub, reg_data, settings)
class(real_subtraction_t), intent(inout), target :: rsub
type(region_data_t), intent(in), target :: reg_data
type(nlo_settings_t), intent(in), target :: settings
integer :: alr
if (debug_on) call msg_debug (D_SUBTRACTION, "real_subtraction_init")
if (debug_on) call msg_debug (D_SUBTRACTION, "n_in", reg_data%n_in)
if (debug_on) call msg_debug (D_SUBTRACTION, "nlegs_born", reg_data%n_legs_born)
if (debug_on) call msg_debug (D_SUBTRACTION, "nlegs_real", reg_data%n_legs_real)
if (debug_on) call msg_debug (D_SUBTRACTION, "reg_data%n_regions", reg_data%n_regions)
if (debug2_active (D_SUBTRACTION)) call reg_data%write ()
rsub%reg_data => reg_data
allocate (rsub%sqme_born (reg_data%n_flv_born))
rsub%sqme_born = zero
allocate (rsub%sqme_born_color_c (reg_data%n_legs_born, reg_data%n_legs_born, &
reg_data%n_flv_born))
rsub%sqme_born_color_c = zero
allocate (rsub%sqme_born_charge_c (reg_data%n_legs_born, reg_data%n_legs_born, &
reg_data%n_flv_born))
rsub%sqme_born_charge_c = zero
allocate (rsub%sqme_real_non_sub (reg_data%n_flv_real, reg_data%n_phs))
rsub%sqme_real_non_sub = zero
allocate (rsub%sc_required (reg_data%n_regions))
do alr = 1, reg_data%n_regions
rsub%sc_required(alr) = reg_data%regions(alr)%sc_required
end do
if (rsub%requires_spin_correlations ()) then
allocate (rsub%sqme_born_spin_c (0:3, 0:3, reg_data%n_legs_born, reg_data%n_flv_born))
rsub%sqme_born_spin_c = zero
end if
call rsub%sub_soft%init (reg_data)
call rsub%sub_coll%init (reg_data%n_regions, reg_data%n_in)
allocate (rsub%sqme_coll_isr (2, 2, reg_data%n_flv_born))
rsub%sqme_coll_isr = zero
rsub%settings => settings
rsub%sub_soft%use_resonance_mappings = settings%use_resonance_mappings
rsub%sub_coll%use_resonance_mappings = settings%use_resonance_mappings
rsub%sub_soft%factorization_mode = settings%factorization_mode
end subroutine real_subtraction_init
@ %def real_subtraction_init
@
<<real subtraction: real subtraction: TBP>>=
procedure :: set_real_kinematics => real_subtraction_set_real_kinematics
<<real subtraction: procedures>>=
subroutine real_subtraction_set_real_kinematics (rsub, real_kinematics)
class(real_subtraction_t), intent(inout) :: rsub
type(real_kinematics_t), intent(in), target :: real_kinematics
rsub%real_kinematics => real_kinematics
end subroutine real_subtraction_set_real_kinematics
@ %def real_subtraction_set_real_kinematics
@
<<real subtraction: real subtraction: TBP>>=
procedure :: set_isr_kinematics => real_subtraction_set_isr_kinematics
<<real subtraction: procedures>>=
subroutine real_subtraction_set_isr_kinematics (rsub, fractions)
class(real_subtraction_t), intent(inout) :: rsub
type(isr_kinematics_t), intent(in), target :: fractions
rsub%isr_kinematics => fractions
end subroutine real_subtraction_set_isr_kinematics
@ %def real_subtraction_set_isr_kinematics
@
<<real subtraction: real subtraction: TBP>>=
procedure :: get_i_res => real_subtraction_get_i_res
<<real subtraction: procedures>>=
function real_subtraction_get_i_res (rsub, alr) result (i_res)
integer :: i_res
class(real_subtraction_t), intent(inout) :: rsub
integer, intent(in) :: alr
select type (fks_mapping => rsub%reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
i_res = fks_mapping%res_map%alr_to_i_res (alr)
class default
i_res = 0
end select
end function real_subtraction_get_i_res
@ %def real_subtraction_get_i_res
@
\subsection{The real contribution to the cross section}
In each singular region $\alpha$, the real contribution to $\sigma$ is
given by the second summand of eqn. \ref{fks: sub: complete},
\begin{equation}
\label{fks: sub: real}
\sigma^\alpha_{\text{real}} = \int d\Phi_n \int_0^{2\pi} d\phi
\int_{-1}^1 dy \int_0^{\xi_{\text{max}}} d\xi
\left(\frac{1}{\xi}\right)_+ \left(\frac{1}{1-y}\right)_+
\underbrace{\frac{J(\Phi_n, \xi, y, \phi)}{\xi}
\left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]}_{g^\alpha(\xi,y)}.
\end{equation}
Writing out the plus-distribution and introducing $\tilde{\xi} =
\xi/\xi_{\text{max}}$ to set the upper integration limit to 1, this
turns out to be equal to
\begin{equation}
\begin{split}
\sigma^\alpha_{\rm{real}} &= \int d\Phi_n \int_0^{2\pi}d\phi
\int_{-1}^1 \frac{dy}{1-y} \Bigg\{\int_0^1
d\tilde{\xi}\Bigg[\frac{g^\alpha(\tilde{\xi}\xi_{\rm{max}},y)}{\tilde{\xi}}
- \underbrace{\frac{g^\alpha(0,y)}{\tilde{\xi}}}_{\text{soft}} -
\underbrace{\frac{g^\alpha(\tilde{\xi}\xi_{\rm{max}},1)}{\tilde{\xi}}}_{\text{coll.}}
+
\underbrace{\frac{g^\alpha(0,1)}{\tilde{\xi}}}_{\text{coll.+soft}}\Bigg]
\\
&+ \left[\log\xi_{\rm{max}}(y)g^\alpha(0,y) - \log\xi_{\rm{max}}(1)g^\alpha(0,1)\right]\Bigg\}.
\end{split}
\end{equation}
This formula is implemented in \texttt{compute\_sqme\_real\_fin}
<<real subtraction: real subtraction: TBP>>=
procedure :: compute => real_subtraction_compute
<<real subtraction: procedures>>=
subroutine real_subtraction_compute (rsub, emitter, i_phs, alpha_s, &
alpha_qed, separate_alrs, sqme)
class(real_subtraction_t), intent(inout) :: rsub
integer, intent(in) :: emitter, i_phs
logical, intent(in) :: separate_alrs
real(default), intent(inout), dimension(:) :: sqme
real(default), intent(in) :: alpha_s, alpha_qed
real(default) :: sqme_alr, alpha_coupling
integer :: alr, i_con, i_res, this_emitter
logical :: same_emitter
do alr = 1, rsub%reg_data%n_regions
if (allocated (rsub%selected_alr)) then
if (.not. any (rsub%selected_alr == alr)) cycle
end if
sqme_alr = zero
if (emitter > rsub%isr_kinematics%n_in) then
same_emitter = emitter == rsub%reg_data%regions(alr)%emitter
else
same_emitter = rsub%reg_data%regions(alr)%emitter <= rsub%isr_kinematics%n_in
end if
associate (nlo_corr_type => rsub%reg_data%regions(alr)%nlo_correction_type)
if (nlo_corr_type == "QCD") then
alpha_coupling = alpha_s
else if (nlo_corr_type == "QED") then
alpha_coupling = alpha_qed
end if
end associate
if (same_emitter .and. i_phs == rsub%real_kinematics%alr_to_i_phs (alr)) then
i_res = rsub%get_i_res (alr)
this_emitter = rsub%reg_data%regions(alr)%emitter
sqme_alr = rsub%evaluate_emitter_region (alr, this_emitter, i_phs, i_res, &
alpha_coupling)
if (rsub%purpose == INTEGRATION .or. rsub%purpose == FIXED_ORDER_EVENTS) then
i_con = rsub%get_i_contributor (alr)
sqme_alr = sqme_alr * rsub%get_phs_factor (i_con)
end if
end if
if (separate_alrs) then
sqme(alr) = sqme(alr) + sqme_alr
else
sqme(1) = sqme(1) + sqme_alr
end if
end do
if (debug2_active (D_SUBTRACTION)) call check_s_alpha_consistency ()
contains
subroutine check_s_alpha_consistency ()
real(default) :: sum_s_alpha, sum_s_alpha_soft
integer :: i_reg, i1, i2
if (debug_on) call msg_debug2 (D_SUBTRACTION, "Check consistency of s_alpha: ")
do i_reg = 1, rsub%reg_data%n_regions
sum_s_alpha = zero; sum_s_alpha_soft = zero
do alr = 1, rsub%reg_data%regions(i_reg)%nregions
call rsub%reg_data%regions(i_reg)%ftuples(alr)%get (i1, i2)
call rsub%evaluate_emitter_region_debug (i_reg, alr, i1, i2, i_phs, &
sum_s_alpha, sum_s_alpha_soft)
end do
end do
end subroutine check_s_alpha_consistency
end subroutine real_subtraction_compute
@ %def real_subtraction_compute
@ The emitter is fixed. We now have to decide whether we evaluate in ISR or FSR
region, and also if resonances are used.
<<real subtraction: real subtraction: TBP>>=
procedure :: evaluate_emitter_region => real_subtraction_evaluate_emitter_region
<<real subtraction: procedures>>=
function real_subtraction_evaluate_emitter_region (rsub, alr, emitter, &
i_phs, i_res, alpha_coupling) result (sqme)
real(default) :: sqme
class(real_subtraction_t), intent(inout) :: rsub
integer, intent(in) :: alr, emitter, i_phs, i_res
real(default), intent(in) :: alpha_coupling
if (emitter <= rsub%isr_kinematics%n_in) then
sqme = rsub%evaluate_region_isr (alr, emitter, i_phs, i_res, alpha_coupling)
else
select type (fks_mapping => rsub%reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
call fks_mapping%set_resonance_momenta &
(rsub%real_kinematics%xi_ref_momenta)
end select
sqme = rsub%evaluate_region_fsr (alr, emitter, i_phs, i_res, alpha_coupling)
end if
end function real_subtraction_evaluate_emitter_region
@ %def real_subtraction_evaluate_emitter_region
@
<<real subtraction: real subtraction: TBP>>=
procedure :: evaluate_emitter_region_debug &
=> real_subtraction_evaluate_emitter_region_debug
<<real subtraction: procedures>>=
subroutine real_subtraction_evaluate_emitter_region_debug (rsub, i_reg, alr, i1, i2, &
i_phs, sum_s_alpha, sum_s_alpha_soft)
class(real_subtraction_t), intent(inout) :: rsub
integer, intent(in) :: i_reg, alr, i1, i2, i_phs
real(default), intent(inout) :: sum_s_alpha, sum_s_alpha_soft
type(vector4_t), dimension(:), allocatable :: p_real, p_born
integer :: i_res
allocate (p_real (rsub%reg_data%n_legs_real))
allocate (p_born (rsub%reg_data%n_legs_born))
if (rsub%reg_data%has_pseudo_isr ()) then
p_real = rsub%real_kinematics%p_real_onshell(i_phs)%get_momenta (i_phs)
p_born = rsub%real_kinematics%p_born_onshell%get_momenta (1)
else
p_real = rsub%real_kinematics%p_real_cms%get_momenta (i_phs)
p_born = rsub%real_kinematics%p_born_cms%get_momenta (1)
end if
i_res = rsub%get_i_res (i_reg)
sum_s_alpha = sum_s_alpha + rsub%reg_data%get_svalue (p_real, i_reg, i1, i2, i_res)
associate (r => rsub%real_kinematics)
if (i1 > rsub%sub_soft%reg_data%n_in) then
call rsub%sub_soft%create_softvec_fsr (p_born, r%y_soft(i_phs), r%phi, &
i1, r%xi_ref_momenta(rsub%sub_soft%i_xi_ref (i_reg, i_phs)))
else
call rsub%sub_soft%create_softvec_isr (r%y_soft(i_phs), r%phi)
end if
end associate
sum_s_alpha_soft = sum_s_alpha_soft + rsub%reg_data%get_svalue_soft &
(p_born, rsub%sub_soft%p_soft, i_reg, i1, i_res)
end subroutine real_subtraction_evaluate_emitter_region_debug
@ %def real_subtraction_evaluate_emitter_region_debug
@ This subroutine computes the finite part of the real matrix element in
an individual singular region.
First, the radiation variables are fetched and $\mathcal{R}$ is
multiplied by the appropriate $S_\alpha$-factors,
region multiplicities and double-FSR factors.
Then, it computes the soft, collinear, soft-collinear and remnant matrix
elements and supplies the corresponding factor $1/\xi/(1-y)$ as well as
the corresponding jacobians.
<<real subtraction: real subtraction: TBP>>=
procedure :: evaluate_region_fsr => real_subtraction_evaluate_region_fsr
<<real subtraction: procedures>>=
function real_subtraction_evaluate_region_fsr (rsub, alr, emitter, i_phs, &
i_res, alpha_coupling) result (sqme_tot)
real(default) :: sqme_tot
class(real_subtraction_t), intent(inout) :: rsub
integer, intent(in) :: alr, emitter, i_phs, i_res
real(default), intent(in) :: alpha_coupling
real(default) :: sqme_rad, sqme_soft, sqme_coll, sqme_cs, sqme_remn
sqme_rad = zero; sqme_soft = zero; sqme_coll = zero
sqme_cs = zero; sqme_remn = zero
associate (region => rsub%reg_data%regions(alr), template => rsub%settings%fks_template)
if (rsub%radiation_event) then
sqme_rad = rsub%sqme_real_non_sub (rsub%reg_data%get_matrix_element_index (alr), i_phs)
call evaluate_fks_factors (sqme_rad, rsub%reg_data, rsub%real_kinematics, &
alr, i_phs, emitter, i_res)
call apply_kinematic_factors_radiation (sqme_rad, rsub%purpose, &
rsub%real_kinematics, i_phs, .false., rsub%reg_data%has_pseudo_isr (), &
emitter)
end if
if (rsub%subtraction_event .and. .not. rsub%subtraction_deactivated) then
if (debug2_active (D_SUBTRACTION)) then
print *, "[real_subtraction_evaluate_region_fsr]"
print *, "xi: ", rsub%real_kinematics%xi_max(i_phs) * rsub%real_kinematics%xi_tilde
print *, "y: ", rsub%real_kinematics%y(i_phs)
end if
call rsub%evaluate_subtraction_terms_fsr (alr, emitter, i_phs, i_res, alpha_coupling, &
sqme_soft, sqme_coll, sqme_cs)
call apply_kinematic_factors_subtraction_fsr (sqme_soft, sqme_coll, sqme_cs, &
rsub%real_kinematics, i_phs)
sqme_remn = compute_sqme_remnant_fsr (sqme_soft, sqme_cs, &
rsub%real_kinematics%xi_max(i_phs), template%xi_cut, rsub%real_kinematics%xi_tilde)
select case (rsub%purpose)
case (INTEGRATION)
sqme_tot = sqme_rad - sqme_soft - sqme_coll + sqme_cs + sqme_remn
case (FIXED_ORDER_EVENTS)
sqme_tot = - sqme_soft - sqme_coll + sqme_cs + sqme_remn
case default
sqme_tot = zero
call msg_bug ("real_subtraction_evaluate_region_fsr: " // &
"Undefined rsub%purpose")
end select
else
sqme_tot = sqme_rad
end if
sqme_tot = sqme_tot * rsub%real_kinematics%jac_rand(i_phs)
end associate
if (debug_active (D_SUBTRACTION) .and. .not. debug2_active (D_SUBTRACTION)) then
- call register_debug_sqme ()
+ call real_subtraction_register_debug_sqme (rsub, alr, emitter, i_phs, sqme_rad, sqme_soft, &
+ sqme_coll=sqme_coll, sqme_cs=sqme_cs)
else if (debug2_active (D_SUBTRACTION)) then
- call write_computation_status ()
+ call write_computation_status_fsr ()
end if
contains
<<real subtraction: real subtraction evaluate region fsr: procedures>>
- subroutine register_debug_sqme ()
- real(default), dimension(:), allocatable, save :: sqme_rad_store
- logical :: soft, collinear
- real(default), parameter :: soft_threshold = 0.01_default
- real(default), parameter :: coll_threshold = 0.01_default
- real(default) :: this_sqme_rad, s_alpha, E_gluon
- logical, dimension(:), allocatable, save :: count_alr
- logical :: write_histo = .true.
- if (.not. allocated (sqme_rad_store)) then
- allocate (sqme_rad_store (rsub%reg_data%n_regions))
- sqme_rad_store = zero
- end if
- if (rsub%radiation_event) then
- sqme_rad_store(alr) = sqme_rad
- else
- if (.not. allocated (count_alr)) then
- allocate (count_alr (rsub%reg_data%n_regions))
- count_alr = .false.
- end if
- associate (p_real => rsub%real_kinematics%p_real_cms)
- E_gluon = p_real%get_energy (i_phs, rsub%reg_data%n_legs_real)
- s_alpha = rsub%reg_data%get_svalue (p_real%get_momenta(i_phs), alr, emitter, i_res)
- end associate
- soft = E_gluon < soft_threshold
- collinear = abs (s_alpha - one) < coll_threshold
- this_sqme_rad = sqme_rad_store(alr)
- if (soft) then
- !!! Do not write sqme_rad twice
- if (write_histo .and. .not. rsub%radiation_event) &
- call write_point_to_file (E_gluon, this_sqme_rad, sqme_soft)
- if ( .not. nearly_equal (this_sqme_rad, sqme_soft, &
- abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then
- call msg_print_color (char ("Soft MEs do not match in region " // str (alr)), COL_RED)
- else
- call msg_print_color (char ("sqme_soft OK in region " // str (alr)), COL_GREEN)
- end if
- print *, 'this_sqme_rad, sqme_soft = ', this_sqme_rad, sqme_soft
- end if
- if (collinear) then
- if ( .not. nearly_equal (this_sqme_rad, sqme_coll, &
- abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then
- call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED)
- else
- call msg_print_color (char ("sqme_coll OK in region " // str (alr)), COL_GREEN)
- end if
- print *, 'this_sqme_rad, sqme_coll = ', this_sqme_rad, sqme_coll
- end if
- if (soft .and. collinear) then
- if ( .not. nearly_equal (this_sqme_rad, sqme_cs, &
- abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then
- call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED)
- else
- call msg_print_color (char ("sqme_cs OK in region " // str (alr)), COL_GREEN)
- end if
- print *, 'this_sqme_rad, sqme_cs = ', this_sqme_rad, sqme_cs
- end if
- count_alr (alr) = .true.
- if (all (count_alr)) then
- deallocate (count_alr)
- deallocate (sqme_rad_store)
- end if
- end if
- end subroutine register_debug_sqme
-
- subroutine write_computation_status (passed, total, region_type, full)
+ subroutine write_computation_status_fsr (passed, total, region_type, full)
integer, intent(in), optional :: passed, total
character(*), intent(in), optional :: region_type
integer :: i_born
integer :: u
real(default) :: xi
logical :: yorn
logical, intent(in), optional :: full
yorn = .true.
if (present (full)) yorn = full
if (debug_on) call msg_debug (D_SUBTRACTION, "real_subtraction_evaluate_region_fsr")
u = given_output_unit (); if (u < 0) return
i_born = rsub%reg_data%regions(alr)%uborn_index
xi = rsub%real_kinematics%xi_max (i_phs) * rsub%real_kinematics%xi_tilde
write (u,'(A,I2)') 'rsub%purpose: ', rsub%purpose
write (u,'(A,I3)') 'alr: ', alr
write (u,'(A,I3)') 'emitter: ', emitter
write (u,'(A,I3)') 'i_phs: ', i_phs
write (u,'(A,F6.4)') 'xi_max: ', rsub%real_kinematics%xi_max (i_phs)
write (u,'(A,F6.4)') 'xi_cut: ', rsub%real_kinematics%xi_max(i_phs) * rsub%settings%fks_template%xi_cut
write (u,'(A,F6.4,2X,A,F6.4)') 'xi: ', xi, 'y: ', rsub%real_kinematics%y (i_phs)
if (yorn) then
write (u,'(A,ES16.9)') 'sqme_born: ', rsub%sqme_born(i_born)
write (u,'(A,ES16.9)') 'sqme_real: ', sqme_rad
write (u,'(A,ES16.9)') 'sqme_soft: ', sqme_soft
write (u,'(A,ES16.9)') 'sqme_coll: ', sqme_coll
write (u,'(A,ES16.9)') 'sqme_coll-soft: ', sqme_cs
write (u,'(A,ES16.9)') 'sqme_remn: ', sqme_remn
write (u,'(A,ES16.9)') 'sqme_tot: ', sqme_tot
if (present (passed) .and. present (total) .and. &
present (region_type)) &
write (u,'(A)') char (str (passed) // " of " // str (total) // &
" " // region_type // " points passed in total")
end if
write (u,'(A,ES16.9)') 'jacobian - real: ', rsub%real_kinematics%jac(i_phs)%jac(1)
write (u,'(A,ES16.9)') 'jacobian - soft: ', rsub%real_kinematics%jac(i_phs)%jac(2)
write (u,'(A,ES16.9)') 'jacobian - coll: ', rsub%real_kinematics%jac(i_phs)%jac(3)
- end subroutine write_computation_status
-
- subroutine write_point_to_file (E_gluon, sqme_rad, sqme_soft)
- real(default), intent(in) :: E_gluon, sqme_rad, sqme_soft
- integer, save :: funit = 0
- type(string_t) :: filename
- filename = var_str ("soft.log")
- if (funit == 0) then
- funit = free_unit ()
- open (funit, file=char(filename), action = "write", status="replace")
- write (funit, "(A,5X,A,5X,A)") "# E_gluon", "Real", "Soft Approx"
- end if
- write (funit,'(3(ES16.9,1X))') E_gluon, sqme_rad, sqme_soft
- end subroutine write_point_to_file
-
+ end subroutine write_computation_status_fsr
end function real_subtraction_evaluate_region_fsr
@ %def real_subtraction_evalute_region_fsr
+@ Compares the real matrix element to the subtraction terms in the soft, the collinear
+or the soft-collinear limits. Used for debug purposes if [[?test_anti_coll_limit]],
+[[?test_coll_limit]] and/or [[?test_soft_limit]] are set in the Sindarin.
+[[sqme_soft]] and [[sqme_cs]] need to be provided if called for FSR and [[sqme_coll_plus]],
+[[sqme_coll_minus]], [[sqme_cs_plus]] as well as [[sqme_cs_minus]] need to be provided if called for ISR.
+<<real subtraction: procedures>>=
+ subroutine real_subtraction_register_debug_sqme (rsub, alr, emitter, i_phs, sqme_rad, sqme_soft,&
+ sqme_coll, sqme_cs, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus)
+ class(real_subtraction_t), intent(in) :: rsub
+ integer, intent(in) :: alr, emitter, i_phs
+ real(default), intent(in) :: sqme_rad, sqme_soft
+ real(default), intent(in), optional :: sqme_coll, sqme_cs, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus
+ real(default), dimension(:), allocatable, save :: sqme_rad_store
+ logical :: is_soft, is_collinear_plus, is_collinear_minus, is_fsr
+ real(default), parameter :: soft_threshold = 0.01_default
+ real(default), parameter :: coll_threshold = 0.99_default
+ real(default) :: sqme_dummy, this_sqme_rad, E_gluon, y
+ logical, dimension(:), allocatable, save :: count_alr
+
+ if (.not. allocated (sqme_rad_store)) then
+ allocate (sqme_rad_store (rsub%reg_data%n_regions))
+ sqme_rad_store = zero
+ end if
+ if (rsub%radiation_event) then
+ sqme_rad_store(alr) = sqme_rad
+ else
+ if (.not. allocated (count_alr)) then
+ allocate (count_alr (rsub%reg_data%n_regions))
+ count_alr = .false.
+ end if
+
+ if (is_gluon (rsub%reg_data%regions(alr)%flst_real%flst(rsub%reg_data%n_legs_real))) then
+ E_gluon = rsub%real_kinematics%p_real_cms%get_energy (i_phs, rsub%reg_data%n_legs_real)
+ is_soft = E_gluon < soft_threshold
+ else
+ is_soft = .false.
+ end if
+ y = rsub%real_kinematics%y(i_phs)
+ is_collinear_plus = y > coll_threshold
+ is_collinear_minus = -y > coll_threshold
+
+ is_fsr = emitter > rsub%isr_kinematics%n_in
+ if (is_fsr) then
+ if (.not. present(sqme_coll) .or. .not. present(sqme_cs)) &
+ call msg_error ("real_subtraction_register_debug_sqme: Wrong arguments for FSR")
+ else
+ if (.not. present(sqme_coll_plus) .or. .not. present(sqme_coll_minus) &
+ .or. .not. present(sqme_cs_plus) .or. .not. present(sqme_cs_minus)) &
+ call msg_error ("real_subtraction_register_debug_sqme: Wrong arguments for ISR")
+ end if
+
+ this_sqme_rad = sqme_rad_store(alr)
+ if (is_soft .and. .not. is_collinear_plus .and. .not. is_collinear_minus) then
+ if ( .not. nearly_equal (this_sqme_rad, sqme_soft, &
+ abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then
+ call msg_print_color (char ("Soft MEs do not match in region " // str (alr)), COL_RED)
+ else
+ call msg_print_color (char ("sqme_soft OK in region " // str (alr)), COL_GREEN)
+ end if
+ print *, 'this_sqme_rad, sqme_soft = ', this_sqme_rad, sqme_soft
+ end if
+
+ if (is_collinear_plus .and. .not. is_soft) then
+ if (is_fsr) then
+ if ( .not. nearly_equal (this_sqme_rad, sqme_coll, &
+ abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then
+ call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED)
+ else
+ call msg_print_color (char ("sqme_coll OK in region " // str (alr)), COL_GREEN)
+ end if
+ print *, 'this_sqme_rad, sqme_coll = ', this_sqme_rad, sqme_coll
+ else
+ if ( .not. nearly_equal (this_sqme_rad, sqme_coll_plus, &
+ abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then
+ call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED)
+ else
+ call msg_print_color (char ("sqme_coll_plus OK in region " // str (alr)), COL_GREEN)
+ end if
+ print *, 'this_sqme_rad, sqme_coll_plus = ', this_sqme_rad, sqme_coll_plus
+ end if
+ end if
+
+ if (is_collinear_minus .and. .not. is_soft) then
+ if (.not. is_fsr) then
+ if ( .not. nearly_equal (this_sqme_rad, sqme_coll_minus, &
+ abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then
+ call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED)
+ else
+ call msg_print_color (char ("sqme_coll_minus OK in region " // str (alr)), COL_GREEN)
+ end if
+ print *, 'this_sqme_rad, sqme_coll_minus = ', this_sqme_rad, sqme_coll_minus
+ end if
+ end if
+
+ if (is_soft .and. is_collinear_plus) then
+ if (is_fsr) then
+ if ( .not. nearly_equal (this_sqme_rad, sqme_cs, &
+ abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then
+ call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED)
+ else
+ call msg_print_color (char ("sqme_cs OK in region " // str (alr)), COL_GREEN)
+ end if
+ print *, 'this_sqme_rad, sqme_cs = ', this_sqme_rad, sqme_cs
+ else
+ if ( .not. nearly_equal (this_sqme_rad, sqme_cs_plus, &
+ abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then
+ call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED)
+ else
+ call msg_print_color (char ("sqme_cs_plus OK in region " // str (alr)), COL_GREEN)
+ end if
+ print *, 'this_sqme_rad, sqme_cs_plus = ', this_sqme_rad, sqme_cs_plus
+ end if
+ end if
+
+ if (is_soft .and. is_collinear_minus) then
+ if ( .not. nearly_equal (this_sqme_rad, sqme_cs_minus, &
+ abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then
+ call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED)
+ else
+ call msg_print_color (char ("sqme_cs_minus OK in region " // str (alr)), COL_GREEN)
+ end if
+ print *, 'this_sqme_rad, sqme_cs_minus = ', this_sqme_rad, sqme_cs_minus
+ end if
+
+ count_alr (alr) = .true.
+ if (all (count_alr)) then
+ deallocate (count_alr)
+ deallocate (sqme_rad_store)
+ end if
+ end if
+ end subroutine real_subtraction_register_debug_sqme
+
+@ %def real_subtraction_register_debug_sqme
@ For final state radiation, the subtraction remnant cross section is
\begin{equation}
\sigma_{\text{remn}} = \left(\sigma_{\text{soft}} - \sigma_{\text{soft-coll}}\right)
\log (\xi_{\text{max}}\xi_{\text{cut}})) \cdot \tilde{\xi}.
\end{equation}
We use the already computed [[sqme_soft]] and [[sqme_cs]] with a factor of
$\tilde{\xi}$ which we have to compensate.
<<real subtraction: real subtraction evaluate region fsr: procedures>>=
function compute_sqme_remnant_fsr (sqme_soft, sqme_cs, xi_max, xi_cut, xi_tilde) result (sqme_remn)
real(default) :: sqme_remn
real(default), intent(in) :: sqme_soft, sqme_cs, xi_max, xi_cut, xi_tilde
if (debug_on) call msg_debug (D_SUBTRACTION, "compute_sqme_remnant_fsr")
sqme_remn = zero
sqme_remn = sqme_remn + (sqme_soft - sqme_cs) * log (xi_max * xi_cut) * xi_tilde
end function compute_sqme_remnant_fsr
@ %def compute_sqme_remnant_fsr
@
<<real subtraction: real subtraction: TBP>>=
procedure :: evaluate_region_isr => real_subtraction_evaluate_region_isr
<<real subtraction: procedures>>=
function real_subtraction_evaluate_region_isr (rsub, alr, emitter, i_phs, i_res, alpha_coupling) &
result (sqme_tot)
real(default) :: sqme_tot
class(real_subtraction_t), intent(inout) :: rsub
integer, intent(in) :: alr, emitter, i_phs, i_res
real(default), intent(in) :: alpha_coupling
real(default) :: sqme_rad, sqme_soft, sqme_coll_plus, sqme_coll_minus
real(default) :: sqme_cs_plus, sqme_cs_minus
real(default) :: sqme_remn
sqme_rad = zero; sqme_soft = zero;
sqme_coll_plus = zero; sqme_coll_minus = zero
sqme_cs_plus = zero; sqme_cs_minus = zero
sqme_remn = zero
associate (region => rsub%reg_data%regions(alr), template => rsub%settings%fks_template)
if (rsub%radiation_event) then
sqme_rad = rsub%sqme_real_non_sub (rsub%reg_data%get_matrix_element_index (alr), i_phs)
call evaluate_fks_factors (sqme_rad, rsub%reg_data, rsub%real_kinematics, &
alr, i_phs, emitter, i_res)
call apply_kinematic_factors_radiation (sqme_rad, rsub%purpose, rsub%real_kinematics, &
i_phs, .true., .false.)
end if
if (rsub%subtraction_event .and. .not. rsub%subtraction_deactivated) then
call rsub%evaluate_subtraction_terms_isr (alr, emitter, i_phs, i_res, alpha_coupling, &
sqme_soft, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus)
call apply_kinematic_factors_subtraction_isr (sqme_soft, sqme_coll_plus, &
sqme_coll_minus, sqme_cs_plus, sqme_cs_minus, rsub%real_kinematics, i_phs)
sqme_remn = compute_sqme_remnant_isr (rsub%isr_kinematics%isr_mode, &
sqme_soft, sqme_cs_plus, sqme_cs_minus, &
rsub%isr_kinematics, rsub%real_kinematics, i_phs, template%xi_cut)
sqme_tot = sqme_rad - sqme_soft - sqme_coll_plus - sqme_coll_minus &
+ sqme_cs_plus + sqme_cs_minus + sqme_remn
else
sqme_tot = sqme_rad
end if
end associate
sqme_tot = sqme_tot * rsub%real_kinematics%jac_rand (i_phs)
- call debug_output ()
+ if (debug_active (D_SUBTRACTION) .and. .not. debug2_active (D_SUBTRACTION)) then
+ call real_subtraction_register_debug_sqme (rsub, alr, emitter, i_phs, sqme_rad,&
+ sqme_soft, sqme_coll_plus=sqme_coll_plus, sqme_coll_minus=sqme_coll_minus,&
+ sqme_cs_plus=sqme_cs_plus, sqme_cs_minus=sqme_cs_minus)
+ else if (debug2_active (D_SUBTRACTION)) then
+ call write_computation_status_isr ()
+ end if
contains
-
- subroutine debug_output ()
- logical :: soft
- type(vector4_t) :: p_gluon
- if (debug_active (D_SUBTRACTION)) then
- call msg_debug (D_SUBTRACTION, "real_subtraction_evaluate_region_isr")
- if (debug2_active (D_SUBTRACTION)) then
- call write_computation_status ()
- else
- associate (p_real => rsub%real_kinematics%p_real_cms)
- p_gluon = p_real%get_momentum (i_phs, p_real%get_n_momenta (i_phs))
- soft = p_gluon%p(0) < 2.0_default
- end associate
- if (soft) then
- if (abs (sqme_rad - sqme_soft) > sqme_rad .and. sqme_soft > tiny_10) then
- call msg_warning ("Soft MEs do not match in soft region")
- call write_computation_status ()
- end if
- end if
- end if
- end if
- end subroutine debug_output
-
- subroutine write_computation_status (unit)
+ <<real subtraction: evaluate region isr: procedures>>
+ subroutine write_computation_status_isr (unit)
integer, intent(in), optional :: unit
integer :: i_born
integer :: u
real(default) :: xi
u = given_output_unit (unit); if (u < 0) return
i_born = rsub%reg_data%regions(alr)%uborn_index
xi = rsub%real_kinematics%xi_max (i_phs) * rsub%real_kinematics%xi_tilde
write (u,'(A,I2)') 'alr: ', alr
write (u,'(A,I2)') 'emitter: ', emitter
write (u,'(A,F4.2)') 'xi_max: ', rsub%real_kinematics%xi_max (i_phs)
print *, 'xi: ', xi, 'y: ', rsub%real_kinematics%y (i_phs)
print *, 'xb1: ', rsub%isr_kinematics%x(1), 'xb2: ', rsub%isr_kinematics%x(2)
print *, 'random jacobian: ', rsub%real_kinematics%jac_rand (i_phs)
write (u,'(A,ES16.9)') 'sqme_born: ', rsub%sqme_born(i_born)
write (u,'(A,ES16.9)') 'sqme_real: ', sqme_rad
write (u,'(A,ES16.9)') 'sqme_soft: ', sqme_soft
write (u,'(A,ES16.9)') 'sqme_coll_plus: ', sqme_coll_plus
write (u,'(A,ES16.9)') 'sqme_coll_minus: ', sqme_coll_minus
write (u,'(A,ES16.9)') 'sqme_cs_plus: ', sqme_cs_plus
write (u,'(A,ES16.9)') 'sqme_cs_minus: ', sqme_cs_minus
write (u,'(A,ES16.9)') 'sqme_remn: ', sqme_remn
write (u,'(A,ES16.9)') 'sqme_tot: ', sqme_tot
write (u,'(A,ES16.9)') 'jacobian - real: ', rsub%real_kinematics%jac(i_phs)%jac(1)
write (u,'(A,ES16.9)') 'jacobian - soft: ', rsub%real_kinematics%jac(i_phs)%jac(2)
write (u,'(A,ES16.9)') 'jacobian - collplus: ', rsub%real_kinematics%jac(i_phs)%jac(3)
write (u,'(A,ES16.9)') 'jacobian - collminus: ', rsub%real_kinematics%jac(i_phs)%jac(4)
-
- end subroutine write_computation_status
- <<real subtraction: evaluate region isr: procedures>>
+ end subroutine write_computation_status_isr
end function real_subtraction_evaluate_region_isr
@ %def real_subtraction_evaluate_region_isr
@
<<real subtraction: evaluate region isr: procedures>>=
function compute_sqme_remnant_isr (isr_mode, sqme_soft, sqme_cs_plus, sqme_cs_minus, &
isr_kinematics, real_kinematics, i_phs, xi_cut) result (sqme_remn)
real(default) :: sqme_remn
integer, intent(in) :: isr_mode
real(default), intent(in) :: sqme_soft, sqme_cs_plus, sqme_cs_minus
type(isr_kinematics_t), intent(in) :: isr_kinematics
type(real_kinematics_t), intent(in) :: real_kinematics
integer, intent(in) :: i_phs
real(default), intent(in) :: xi_cut
real(default) :: xi_tilde, xi_max, xi_max_plus, xi_max_minus
xi_max = real_kinematics%xi_max (i_phs)
select case (isr_mode)
case (SQRTS_VAR)
xi_max_plus = one - isr_kinematics%x(I_PLUS)
xi_max_minus = one - isr_kinematics%x(I_MINUS)
case (SQRTS_FIXED)
xi_max_plus = real_kinematics%xi_max (i_phs)
xi_max_minus = real_kinematics%xi_max (i_phs)
end select
xi_tilde = real_kinematics%xi_tilde
sqme_remn = log(xi_max * xi_cut) * xi_tilde * sqme_soft
sqme_remn = sqme_remn - log (xi_max_plus * xi_cut) * xi_tilde * sqme_cs_plus &
- log (xi_max_minus * xi_cut) * xi_tilde * sqme_cs_minus
end function compute_sqme_remnant_isr
@ %def compute_sqme_remnant_isr
@
<<real subtraction: real subtraction: TBP>>=
procedure :: evaluate_subtraction_terms_fsr => &
real_subtraction_evaluate_subtraction_terms_fsr
<<real subtraction: procedures>>=
subroutine real_subtraction_evaluate_subtraction_terms_fsr (rsub, &
alr, emitter, i_phs, i_res, alpha_coupling, sqme_soft, sqme_coll, sqme_cs)
class(real_subtraction_t), intent(inout) :: rsub
integer, intent(in) :: alr, emitter, i_phs, i_res
real(default), intent(in) :: alpha_coupling
real(default), intent(out) :: sqme_soft, sqme_coll, sqme_cs
if (debug_on) call msg_debug (D_SUBTRACTION, "real_subtraction_evaluate_subtraction_terms_fsr")
sqme_soft = zero; sqme_coll = zero; sqme_cs = zero
associate (xi_tilde => rsub%real_kinematics%xi_tilde, &
y => rsub%real_kinematics%y(i_phs), template => rsub%settings%fks_template)
if (template%xi_cut > xi_tilde) &
sqme_soft = rsub%compute_sub_soft (alr, emitter, i_phs, i_res, alpha_coupling)
if (y - 1 + template%delta_o > 0) &
sqme_coll = rsub%compute_sub_coll (alr, emitter, i_phs, alpha_coupling)
if (template%xi_cut > xi_tilde .and. y - 1 + template%delta_o > 0) &
sqme_cs = rsub%compute_sub_coll_soft (alr, emitter, i_phs, alpha_coupling)
if (debug2_active (D_SUBTRACTION)) then
print *, "FSR Cutoff:"
print *, "sub_soft: ", template%xi_cut > xi_tilde, "(ME: ", sqme_soft, ")"
print *, "sub_coll: ", (y - 1 + template%delta_o) > 0, "(ME: ", sqme_coll, ")"
print *, "sub_coll_soft: ", template%xi_cut > xi_tilde .and. (y - 1 + template%delta_o) > 0, &
"(ME: ", sqme_cs, ")"
end if
end associate
end subroutine real_subtraction_evaluate_subtraction_terms_fsr
@ %def real_subtraction_evaluate_subtraction_terms_fsr
@
<<real subtraction: procedures>>=
subroutine evaluate_fks_factors (sqme, reg_data, real_kinematics, &
alr, i_phs, emitter, i_res)
real(default), intent(inout) :: sqme
type(region_data_t), intent(inout) :: reg_data
type(real_kinematics_t), intent(in), target :: real_kinematics
integer, intent(in) :: alr, i_phs, emitter, i_res
real(default) :: s_alpha
type(phs_point_set_t), pointer :: p_real => null ()
if (reg_data%has_pseudo_isr ()) then
p_real => real_kinematics%p_real_onshell (i_phs)
else
p_real => real_kinematics%p_real_cms
end if
s_alpha = reg_data%get_svalue (p_real%get_momenta(i_phs), alr, emitter, i_res)
if (debug2_active (D_SUBTRACTION)) call msg_print_color('s_alpha', s_alpha, COL_YELLOW)
if (s_alpha > one + tiny_07) call msg_fatal ("s_alpha > 1!")
sqme = sqme * s_alpha
associate (region => reg_data%regions(alr))
sqme = sqme * region%mult
if (emitter > reg_data%n_in) then
if (debug2_active (D_SUBTRACTION)) &
print *, 'Double FSR: ', region%double_fsr_factor (p_real%get_momenta(i_phs))
sqme = sqme * region%double_fsr_factor (p_real%get_momenta(i_phs))
end if
end associate
end subroutine evaluate_fks_factors
@ %def evaluate_fks_factors
@
<<real subtraction: procedures>>=
subroutine apply_kinematic_factors_radiation (sqme, purpose, real_kinematics, &
i_phs, isr, threshold, emitter)
real(default), intent(inout) :: sqme
integer, intent(in) :: purpose
type(real_kinematics_t), intent(in) :: real_kinematics
integer, intent(in) :: i_phs
logical, intent(in) :: isr, threshold
integer, intent(in), optional :: emitter
real(default) :: xi, xi_tilde, s
xi_tilde = real_kinematics%xi_tilde
xi = xi_tilde * real_kinematics%xi_max (i_phs)
select case (purpose)
case (INTEGRATION, FIXED_ORDER_EVENTS)
sqme = sqme * xi**2 / xi_tilde * real_kinematics%jac(i_phs)%jac(1)
case (POWHEG)
if (.not. isr) then
s = real_kinematics%cms_energy2
sqme = sqme * real_kinematics%jac(i_phs)%jac(1) * s / (8 * twopi3) * xi
else
call msg_fatal ("POWHEG with initial-state radiation not implemented yet")
end if
end select
end subroutine apply_kinematic_factors_radiation
@ %def apply_kinematics_factors_radiation
@
<<real subtraction: procedures>>=
subroutine apply_kinematic_factors_subtraction_fsr &
(sqme_soft, sqme_coll, sqme_cs, real_kinematics, i_phs)
real(default), intent(inout) :: sqme_soft, sqme_coll, sqme_cs
type(real_kinematics_t), intent(in) :: real_kinematics
integer, intent(in) :: i_phs
real(default) :: xi_tilde, onemy
xi_tilde = real_kinematics%xi_tilde
onemy = one - real_kinematics%y(i_phs)
sqme_soft = sqme_soft / onemy / xi_tilde
sqme_coll = sqme_coll / onemy / xi_tilde
sqme_cs = sqme_cs / onemy / xi_tilde
associate (jac => real_kinematics%jac(i_phs)%jac)
sqme_soft = sqme_soft * jac(2)
sqme_coll = sqme_coll * jac(3)
sqme_cs = sqme_cs * jac(2)
end associate
end subroutine apply_kinematic_factors_subtraction_fsr
@ %def apply_kinematic_factors_subtraction_fsr
@
<<real subtraction: procedures>>=
subroutine apply_kinematic_factors_subtraction_isr &
(sqme_soft, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, &
sqme_cs_minus, real_kinematics, i_phs)
real(default), intent(inout) :: sqme_soft, sqme_coll_plus, sqme_coll_minus
real(default), intent(inout) :: sqme_cs_plus, sqme_cs_minus
type(real_kinematics_t), intent(in) :: real_kinematics
integer, intent(in) :: i_phs
real(default) :: xi_tilde, y, onemy, onepy
xi_tilde = real_kinematics%xi_tilde
y = real_kinematics%y (i_phs)
onemy = one - y; onepy = one + y
associate (jac => real_kinematics%jac(i_phs)%jac)
sqme_soft = sqme_soft / (one - y**2) / xi_tilde * jac(2)
sqme_coll_plus = sqme_coll_plus / onemy / xi_tilde / two * jac(3)
sqme_coll_minus = sqme_coll_minus / onepy / xi_tilde / two * jac(4)
sqme_cs_plus = sqme_cs_plus / onemy / xi_tilde / two * jac(2)
sqme_cs_minus = sqme_cs_minus / onepy / xi_tilde / two * jac(2)
end associate
end subroutine apply_kinematic_factors_subtraction_isr
@ %def apply_kinematic_factors_subtraction_isr
@ This subroutine evaluates the soft and collinear subtraction terms for ISR.
References:
\begin{itemize}
\item arXiv:0709.2092, sec. 2.4.2
\item arXiv:0908.4272, sec. 4.2
\end{itemize}
For the collinear terms, the procedure is as follows:
If the emitter is 0, then a gluon was radiated from one of the incoming partons.
Gluon emissions require two counter terms:
One for emission in the direction of the first incoming parton $\oplus$
and a second for emission in the direction of the second incoming parton $\ominus$
because in both cases, there are divergent diagrams contributing to the matrix element.
So in this case both, [[sqme_coll_plus]] and [[sqme_coll_minus]], are non-zero.
If the emitter is 1 or 2, then a quark was emitted instead of a gluon.
This only leads to a divergence collinear to the emitter because for anti-collinear
quark emission, there are simply no divergent diagrams in the same region as two
collinear quarks that cannot originate in the same splitting are non-divergent.
This means that in case the emitter is 1, we need non-zero [[sqme_coll_plus]]
and in case the emitter is 2, we need non-zero [[sqme_coll_minus]].
At this point, we want to remind ourselves that in case of initial state divergences,
$y$ is just the polar angle, so the [[sqme_coll_minus]] terms are there to counter emissions in
the direction of the second incoming parton $\ominus$ and \textbf{not} to counter in general
anti-collinear divergences.
<<real subtraction: real subtraction: TBP>>=
procedure :: evaluate_subtraction_terms_isr => &
real_subtraction_evaluate_subtraction_terms_isr
<<real subtraction: procedures>>=
subroutine real_subtraction_evaluate_subtraction_terms_isr (rsub, &
alr, emitter, i_phs, i_res, alpha_coupling, sqme_soft, sqme_coll_plus, &
sqme_coll_minus, sqme_cs_plus, sqme_cs_minus)
class(real_subtraction_t), intent(inout) :: rsub
integer, intent(in) :: alr, emitter, i_phs, i_res
real(default), intent(in) :: alpha_coupling
real(default), intent(out) :: sqme_soft
real(default), intent(out) :: sqme_coll_plus, sqme_coll_minus
real(default), intent(out) :: sqme_cs_plus, sqme_cs_minus
sqme_coll_plus = zero; sqme_cs_plus = zero
sqme_coll_minus = zero; sqme_cs_minus = zero
associate (xi_tilde => rsub%real_kinematics%xi_tilde, &
y => rsub%real_kinematics%y(i_phs), template => rsub%settings%fks_template)
if (template%xi_cut > xi_tilde) &
sqme_soft = rsub%compute_sub_soft (alr, emitter, i_phs, i_res, alpha_coupling)
if (emitter /= 2) then
if (y - 1 + template%delta_i > 0) then
sqme_coll_plus = rsub%compute_sub_coll (alr, 1, i_phs, alpha_coupling)
if (template%xi_cut > xi_tilde) then
sqme_cs_plus = rsub%compute_sub_coll_soft (alr, 1, i_phs, alpha_coupling)
end if
end if
end if
if (emitter /= 1) then
if (-y - 1 + template%delta_i > 0) then
sqme_coll_minus = rsub%compute_sub_coll (alr, 2, i_phs, alpha_coupling)
if (template%xi_cut > xi_tilde) then
sqme_cs_minus = rsub%compute_sub_coll_soft (alr, 2, i_phs, alpha_coupling)
end if
end if
end if
if (debug2_active (D_SUBTRACTION)) then
print *, "ISR Cutoff:"
print *, "y: ", y
print *, "delta_i: ", template%delta_i
print *, "emitter: ", emitter
print *, "sub_soft: ", template%xi_cut > xi_tilde, "(ME: ", sqme_soft, ")"
print *, "sub_coll_plus: ", (y - 1 + template%delta_i) > 0, "(ME: ", sqme_coll_plus, ")"
print *, "sub_coll_minus: ", (-y - 1 + template%delta_i) > 0, "(ME: ", sqme_coll_minus, ")"
print *, "sub_coll_soft_plus: ", template%xi_cut > xi_tilde .and. (y - 1 + template%delta_i) > 0, &
"(ME: ", sqme_cs_plus, ")"
print *, "sub_coll_soft_minus: ", template%xi_cut > xi_tilde .and. (-y - 1 + template%delta_i) > 0, &
"(ME: ", sqme_cs_minus, ")"
end if
end associate
end subroutine real_subtraction_evaluate_subtraction_terms_isr
@ %def real_subtraction_evaluate_subtraction_terms_isr
@ This is basically the part of the real Jacobian corresponding to
\begin{equation*}
\frac{q^2}{8 (2\pi)^3}.
\end{equation*}
We interpret it as the additional phase space factor of the real component,
to be more consistent with the evaluation of the Born phase space.
<<real subtraction: real subtraction: TBP>>=
procedure :: get_phs_factor => real_subtraction_get_phs_factor
<<real subtraction: procedures>>=
function real_subtraction_get_phs_factor (rsub, i_con) result (factor)
real(default) :: factor
class(real_subtraction_t), intent(in) :: rsub
integer, intent(in) :: i_con
real(default) :: s
s = rsub%real_kinematics%xi_ref_momenta (i_con)**2
factor = s / (8 * twopi3)
end function real_subtraction_get_phs_factor
@ %def real_subtraction_get_phs_factor
@
<<real subtraction: real subtraction: TBP>>=
procedure :: get_i_contributor => real_subtraction_get_i_contributor
<<real subtraction: procedures>>=
function real_subtraction_get_i_contributor (rsub, alr) result (i_con)
integer :: i_con
class(real_subtraction_t), intent(in) :: rsub
integer, intent(in) :: alr
if (allocated (rsub%reg_data%alr_to_i_contributor)) then
i_con = rsub%reg_data%alr_to_i_contributor (alr)
else
i_con = 1
end if
end function real_subtraction_get_i_contributor
@ %def real_subtraction_get_i_contributor
@
<<real subtraction: real subtraction: TBP>>=
procedure :: compute_sub_soft => real_subtraction_compute_sub_soft
<<real subtraction: procedures>>=
function real_subtraction_compute_sub_soft (rsub, alr, emitter, &
i_phs, i_res, alpha_coupling) result (sqme_soft)
real(default) :: sqme_soft
class(real_subtraction_t), intent(inout) :: rsub
integer, intent(in) :: alr, emitter, i_phs, i_res
real(default), intent(in) :: alpha_coupling
integer :: i_xi_ref, i_born
real(default) :: q2
type(vector4_t), dimension(:), allocatable :: p_born
associate (real_kinematics => rsub%real_kinematics, &
nlo_corr_type => rsub%reg_data%regions(alr)%nlo_correction_type)
sqme_soft = zero
if (rsub%reg_data%regions(alr)%has_soft_divergence ()) then
i_xi_ref = rsub%sub_soft%i_xi_ref (alr, i_phs)
q2 = real_kinematics%xi_ref_momenta (i_xi_ref)**2
allocate (p_born (rsub%reg_data%n_legs_born))
if (rsub%reg_data%has_pseudo_isr ()) then
p_born = real_kinematics%p_born_onshell%get_momenta(1)
else
p_born = real_kinematics%p_born_cms%get_momenta(1)
end if
if (emitter > rsub%sub_soft%reg_data%n_in) then
call rsub%sub_soft%create_softvec_fsr &
(p_born, real_kinematics%y_soft(i_phs), &
real_kinematics%phi, emitter, &
real_kinematics%xi_ref_momenta(i_xi_ref))
else
call rsub%sub_soft%create_softvec_isr &
(real_kinematics%y_soft(i_phs), real_kinematics%phi)
end if
i_born = rsub%reg_data%regions(alr)%uborn_index
if (nlo_corr_type == "QCD") then
sqme_soft = rsub%sub_soft%compute &
(p_born, rsub%sqme_born_color_c(:,:,i_born), &
real_kinematics%y(i_phs), &
q2, alpha_coupling, alr, emitter, i_res)
else if (nlo_corr_type == "QED") then
sqme_soft = rsub%sub_soft%compute &
(p_born, rsub%sqme_born_charge_c(:,:,i_born), &
real_kinematics%y(i_phs), &
q2, alpha_coupling, alr, emitter, i_res)
end if
end if
end associate
if (debug2_active (D_SUBTRACTION)) call check_soft_vector ()
contains
subroutine check_soft_vector ()
type(vector4_t) :: p_gluon
if (debug_on) call msg_debug2 (D_SUBTRACTION, "Compare soft vector: ")
print *, 'p_soft: ', rsub%sub_soft%p_soft%p
print *, 'Normalized gluon momentum: '
if (rsub%reg_data%has_pseudo_isr ()) then
p_gluon = rsub%real_kinematics%p_real_onshell(thr_leg(emitter))%get_momentum &
(i_phs, rsub%reg_data%n_legs_real)
else
p_gluon = rsub%real_kinematics%p_real_cms%get_momentum &
(i_phs, rsub%reg_data%n_legs_real)
end if
call vector4_write (p_gluon / p_gluon%p(0), show_mass = .true.)
end subroutine check_soft_vector
end function real_subtraction_compute_sub_soft
@ %def real_subtraction_compute_sub_soft
@
<<real subtraction: real subtraction: TBP>>=
procedure :: get_spin_correlation_term => real_subtraction_get_spin_correlation_term
<<real subtraction: procedures>>=
function real_subtraction_get_spin_correlation_term (rsub, alr, i_born, emitter) &
result (mom_times_sqme)
real(default) :: mom_times_sqme
class(real_subtraction_t), intent(in) :: rsub
integer, intent(in) :: alr, i_born, emitter
real(default), dimension(0:3) :: k_perp
integer :: mu, nu
if (rsub%sc_required(alr)) then
if (debug2_active(D_SUBTRACTION)) call check_me_consistency ()
associate (real_kin => rsub%real_kinematics)
if (emitter > rsub%reg_data%n_in) then
k_perp = real_subtraction_compute_k_perp_fsr ( &
real_kin%p_born_lab%get_momentum(1, emitter), &
rsub%real_kinematics%phi)
else
k_perp = real_subtraction_compute_k_perp_isr ( &
real_kin%p_born_lab%get_momentum(1, emitter), &
rsub%real_kinematics%phi)
end if
end associate
mom_times_sqme = zero
do mu = 0, 3
do nu = 0, 3
mom_times_sqme = mom_times_sqme + &
k_perp(mu) * k_perp(nu) * rsub%sqme_born_spin_c (mu, nu, emitter, i_born)
end do
end do
else
mom_times_sqme = zero
end if
contains
subroutine check_me_consistency ()
real(default) :: sqme_sum
if (debug_on) call msg_debug2 (D_SUBTRACTION, "Spin-correlation: Consistency check")
sqme_sum = rsub%sqme_born_spin_c(0,0,emitter,i_born) &
- rsub%sqme_born_spin_c(1,1,emitter,i_born) &
- rsub%sqme_born_spin_c(2,2,emitter,i_born) &
- rsub%sqme_born_spin_c(3,3,emitter,i_born)
if (.not. nearly_equal (sqme_sum, -rsub%sqme_born(i_born), 0.0001_default)) then
print *, 'Spin-correlated matrix elements are not consistent: '
print *, 'emitter: ', emitter
print *, 'g^{mu,nu} B_{mu,nu}: ', -sqme_sum
print *, 'all Born matrix elements: ', rsub%sqme_born
call msg_fatal ("FAIL")
else
call msg_print_color ("Success", COL_GREEN)
end if
end subroutine check_me_consistency
end function real_subtraction_get_spin_correlation_term
@ %def real_subtraction_get_spin_correlation_term
@ Construct a normalised momentum perpendicular to momentum [[p]] and rotate by
an arbitrary angle [[phi]].
<<real subtraction: public>>=
public :: real_subtraction_compute_k_perp_fsr, &
real_subtraction_compute_k_perp_isr
<<real subtraction: procedures>>=
function real_subtraction_compute_k_perp_fsr (p, phi) result (k_perp_fsr)
real(default), dimension(0:3) :: k_perp_fsr
type(vector4_t), intent(in) :: p
real(default), intent(in) :: phi
type(vector4_t) :: k
type(vector3_t) :: vec
type(lorentz_transformation_t) :: rot
vec = p%p(1:3) / p%p(0)
k%p(0) = zero
k%p(1) = p%p(1); k%p(2) = p%p(2)
k%p(3) = - (p%p(1)**2 + p%p(2)**2) / p%p(3)
rot = rotation (cos(phi), sin(phi), vec)
k = rot * k
k%p(1:3) = k%p(1:3) / space_part_norm (k)
k_perp_fsr = k%p
end function real_subtraction_compute_k_perp_fsr
function real_subtraction_compute_k_perp_isr (p, phi) result (k_perp_isr)
real(default), dimension(0:3) :: k_perp_isr
type(vector4_t), intent(in) :: p
real(default), intent(in) :: phi
k_perp_isr(0) = zero
k_perp_isr(1) = cos(phi)
k_perp_isr(2) = sin(phi)
k_perp_isr(3) = zero
end function real_subtraction_compute_k_perp_isr
@ %def real_subtraction_compute_k_perp_fsr, real_subtraction_compute_k_perp_isr
@
<<real subtraction: real subtraction: TBP>>=
procedure :: compute_sub_coll => real_subtraction_compute_sub_coll
<<real subtraction: procedures>>=
function real_subtraction_compute_sub_coll (rsub, alr, em, i_phs, alpha_coupling) &
result (sqme_coll)
real(default) :: sqme_coll
class(real_subtraction_t), intent(inout) :: rsub
integer, intent(in) :: alr, em, i_phs
real(default), intent(in) :: alpha_coupling
real(default) :: xi, xi_max
real(default) :: mom_times_sqme_spin_c
integer :: i_con, pdf_type
real(default) :: pfr
associate (sregion => rsub%reg_data%regions(alr))
sqme_coll = zero
if (sregion%has_collinear_divergence ()) then
xi = rsub%real_kinematics%xi_tilde * rsub%real_kinematics%xi_max(i_phs)
if (rsub%sub_coll%use_resonance_mappings) then
i_con = rsub%reg_data%alr_to_i_contributor (alr)
else
i_con = 1
end if
mom_times_sqme_spin_c = rsub%get_spin_correlation_term (alr, sregion%uborn_index, em)
if (em <= rsub%sub_coll%n_in) then
select case (rsub%isr_kinematics%isr_mode)
case (SQRTS_FIXED)
xi_max = rsub%real_kinematics%xi_max(i_phs)
case (SQRTS_VAR)
xi_max = one - rsub%isr_kinematics%x(em)
end select
xi = rsub%real_kinematics%xi_tilde * xi_max
! TODO sbrass introduce overall PDF/PDF_SINGLET parameter
if (rsub%reg_data%regions(alr)%flst_real%flst(em) == GLUON) then
pdf_type = 2
else
pdf_type = 1
end if
if (sregion%nlo_correction_type == "QCD") then
call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR)
else if (sregion%nlo_correction_type == "QED") then
call rsub%sub_coll%set_parameters (CA = zero, &
CF = sregion%flst_real%charge(em)**2, &
TR = sregion%flst_real%charge(size(sregion%flst_real%flst))**2)
end if
sqme_coll = rsub%sub_coll%compute_isr (em, sregion%flst_real%flst, &
rsub%real_kinematics%p_born_lab%phs_point(1)%p, &
rsub%sqme_coll_isr(em, pdf_type, sregion%uborn_index), &
mom_times_sqme_spin_c, &
xi, alpha_coupling, rsub%isr_kinematics%isr_mode)
else
if (sregion%nlo_correction_type == "QCD") then
call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR)
else if (sregion%nlo_correction_type == "QED") then
call rsub%sub_coll%set_parameters (CA = zero, &
CF = sregion%flst_real%charge(sregion%emitter)**2, &
TR = sregion%flst_real%charge(sregion%emitter)**2)
end if
sqme_coll = rsub%sub_coll%compute_fsr (sregion%emitter, sregion%flst_real%flst, &
rsub%real_kinematics%xi_ref_momenta (i_con), &
rsub%real_kinematics%p_born_lab%get_momenta(1), &
rsub%sqme_born(sregion%uborn_index), mom_times_sqme_spin_c, &
xi, alpha_coupling, sregion%double_fsr)
if (rsub%sub_coll%use_resonance_mappings) then
select type (fks_mapping => rsub%reg_data%fks_mapping)
type is (fks_mapping_resonances_t)
pfr = fks_mapping%get_resonance_weight (alr, &
rsub%real_kinematics%p_born_cms%get_momenta(1))
end select
sqme_coll = sqme_coll * pfr
end if
end if
end if
end associate
end function real_subtraction_compute_sub_coll
@ %def real_subtraction_compute_sub_coll
@
<<real subtraction: real subtraction: TBP>>=
procedure :: compute_sub_coll_soft => real_subtraction_compute_sub_coll_soft
<<real subtraction: procedures>>=
function real_subtraction_compute_sub_coll_soft (rsub, alr, em, i_phs, alpha_coupling) &
result (sqme_cs)
real(default) :: sqme_cs
class(real_subtraction_t), intent(inout) :: rsub
integer, intent(in) :: alr, em, i_phs
real(default), intent(in) :: alpha_coupling
real(default) :: mom_times_sqme_spin_c
integer :: i_con
associate (sregion => rsub%reg_data%regions(alr))
sqme_cs = zero
if (sregion%has_collinear_divergence ()) then
if (rsub%sub_coll%use_resonance_mappings) then
i_con = rsub%reg_data%alr_to_i_contributor (alr)
else
i_con = 1
end if
mom_times_sqme_spin_c = rsub%get_spin_correlation_term (alr, sregion%uborn_index, em)
if (em <= rsub%sub_coll%n_in) then
if (sregion%nlo_correction_type == "QCD") then
call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR)
else if (sregion%nlo_correction_type == "QED") then
call rsub%sub_coll%set_parameters (CA = zero, &
CF = sregion%flst_real%charge(em)**2, &
TR = sregion%flst_real%charge(size(sregion%flst_real%flst))**2)
end if
sqme_cs = rsub%sub_coll%compute_isr (em, sregion%flst_real%flst, &
rsub%real_kinematics%p_born_lab%phs_point(1)%p, &
rsub%sqme_born(sregion%uborn_index), mom_times_sqme_spin_c, &
zero, alpha_coupling, rsub%isr_kinematics%isr_mode)
else
if (sregion%nlo_correction_type == "QCD") then
call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR)
else if (sregion%nlo_correction_type == "QED") then
call rsub%sub_coll%set_parameters (CA = zero, &
CF = sregion%flst_real%charge(sregion%emitter)**2, &
TR = sregion%flst_real%charge(sregion%emitter)**2)
end if
sqme_cs = rsub%sub_coll%compute_fsr (sregion%emitter, sregion%flst_real%flst, &
rsub%real_kinematics%xi_ref_momenta(i_con), &
rsub%real_kinematics%p_born_lab%phs_point(1)%p, &
rsub%sqme_born(sregion%uborn_index), mom_times_sqme_spin_c, &
zero, alpha_coupling, sregion%double_fsr)
end if
end if
end associate
end function real_subtraction_compute_sub_coll_soft
@ %def real_subtraction_compute_sub_coll_soft
<<real subtraction: real subtraction: TBP>>=
procedure :: requires_spin_correlations => &
real_subtraction_requires_spin_correlations
<<real subtraction: procedures>>=
function real_subtraction_requires_spin_correlations (rsub) result (val)
logical :: val
class(real_subtraction_t), intent(in) :: rsub
val = any (rsub%sc_required)
end function real_subtraction_requires_spin_correlations
@ %def real_subtraction_requires_spin_correlations
@
<<real subtraction: real subtraction: TBP>>=
procedure :: final => real_subtraction_final
<<real subtraction: procedures>>=
subroutine real_subtraction_final (rsub)
class(real_subtraction_t), intent(inout) :: rsub
call rsub%sub_soft%final ()
call rsub%sub_coll%final ()
!!! Finalization of region data is done in pcm_nlo_final
if (associated (rsub%reg_data)) nullify (rsub%reg_data)
!!! Finalization of real kinematics is done in pcm_instance_nlo_final
if (associated (rsub%real_kinematics)) nullify (rsub%real_kinematics)
if (associated (rsub%isr_kinematics)) nullify (rsub%isr_kinematics)
if (allocated (rsub%sqme_real_non_sub)) deallocate (rsub%sqme_real_non_sub)
if (allocated (rsub%sqme_born)) deallocate (rsub%sqme_born)
if (allocated (rsub%sqme_born_color_c)) deallocate (rsub%sqme_born_color_c)
if (allocated (rsub%sqme_born_charge_c)) deallocate (rsub%sqme_born_charge_c)
if (allocated (rsub%sc_required)) deallocate (rsub%sc_required)
if (allocated (rsub%selected_alr)) deallocate (rsub%selected_alr)
end subroutine real_subtraction_final
@ %def real_subtraction_final
@ \subsubsection{Partitions of the real matrix element and Powheg damping}
<<real subtraction: public>>=
public :: real_partition_t
<<real subtraction: types>>=
type, abstract :: real_partition_t
contains
<<real subtraction: real partition: TBP>>
end type real_partition_t
@ %def real partition_t
@
<<real subtraction: real partition: TBP>>=
procedure (real_partition_init), deferred :: init
<<real subtraction: interfaces>>=
abstract interface
subroutine real_partition_init (partition, scale, reg_data)
import
class(real_partition_t), intent(out) :: partition
real(default), intent(in) :: scale
type(region_data_t), intent(in) :: reg_data
end subroutine real_partition_init
end interface
@ %def real_partition_init
@
<<real subtraction: real partition: TBP>>=
procedure (real_partition_write), deferred :: write
<<real subtraction: interfaces>>=
abstract interface
subroutine real_partition_write (partition, unit)
import
class(real_partition_t), intent(in) :: partition
integer, intent(in), optional :: unit
end subroutine real_partition_write
end interface
@ %def real_partition_write
@ To allow really arbitrary damping functions, [[get_f]] should get the
full real phase space as argument and not just some [[pt2]] that is
extracted higher up.
<<real subtraction: real partition: TBP>>=
procedure (real_partition_get_f), deferred :: get_f
<<real subtraction: interfaces>>=
abstract interface
function real_partition_get_f (partition, p) result (f)
import
real(default) :: f
class(real_partition_t), intent(in) :: partition
type(vector4_t), intent(in), dimension(:) :: p
end function real_partition_get_f
end interface
@ %def real_partition_get_f
@
<<real subtraction: public>>=
public :: powheg_damping_simple_t
<<real subtraction: types>>=
type, extends (real_partition_t) :: powheg_damping_simple_t
real(default) :: h2 = 5._default
integer :: emitter
contains
<<real subtraction: powheg damping simple: TBP>>
end type powheg_damping_simple_t
@ %def powheg_damping_simple_t
@
<<real subtraction: powheg damping simple: TBP>>=
procedure :: get_f => powheg_damping_simple_get_f
<<real subtraction: procedures>>=
function powheg_damping_simple_get_f (partition, p) result (f)
real(default) :: f
class(powheg_damping_simple_t), intent(in) :: partition
type(vector4_t), intent(in), dimension(:) :: p
!!! real(default) :: pt2
f = 1
call msg_bug ("Simple damping currently not available")
!!! TODO (cw-2017-03-01) Compute pt2 from emitter)
!!! f = partition%h2 / (pt2 + partition%h2)
end function powheg_damping_simple_get_f
@ %def powheg_damping_simple_get_f
@
<<real subtraction: powheg damping simple: TBP>>=
procedure :: init => powheg_damping_simple_init
<<real subtraction: procedures>>=
subroutine powheg_damping_simple_init (partition, scale, reg_data)
class(powheg_damping_simple_t), intent(out) :: partition
real(default), intent(in) :: scale
type(region_data_t), intent(in) :: reg_data
partition%h2 = scale**2
end subroutine powheg_damping_simple_init
@ %def powheg_damping_simple_init
@
<<real subtraction: powheg damping simple: TBP>>=
procedure :: write => powheg_damping_simple_write
<<real subtraction: procedures>>=
subroutine powheg_damping_simple_write (partition, unit)
class(powheg_damping_simple_t), intent(in) :: partition
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A)") "Powheg damping simple: "
write (u, "(1x,A, "// FMT_15 // ")") "scale h2: ", partition%h2
end subroutine powheg_damping_simple_write
@ %def powheg_damping_simple_write
@
<<real subtraction: public>>=
public :: real_partition_fixed_order_t
<<real subtraction: types>>=
type, extends (real_partition_t) :: real_partition_fixed_order_t
real(default) :: scale
type(ftuple_t), dimension(:), allocatable :: fks_pairs
contains
<<real subtraction: real partition fixed order: TBP>>
end type real_partition_fixed_order_t
@ %def real_partition_fixed_order_t
@
<<real subtraction: real partition fixed order: TBP>>=
procedure :: init => real_partition_fixed_order_init
<<real subtraction: procedures>>=
subroutine real_partition_fixed_order_init (partition, scale, reg_data)
class(real_partition_fixed_order_t), intent(out) :: partition
real(default), intent(in) :: scale
type(region_data_t), intent(in) :: reg_data
end subroutine real_partition_fixed_order_init
@ %def real_partition_fixed_order_init
@
<<real subtraction: real partition fixed order: TBP>>=
procedure :: write => real_partition_fixed_order_write
<<real subtraction: procedures>>=
subroutine real_partition_fixed_order_write (partition, unit)
class(real_partition_fixed_order_t), intent(in) :: partition
integer, intent(in), optional :: unit
end subroutine real_partition_fixed_order_write
@ %def real_partition_fixed_order_write
@
<<real subtraction: real partition fixed order: TBP>>=
procedure :: get_f => real_partition_fixed_order_get_f
<<real subtraction: procedures>>=
function real_partition_fixed_order_get_f (partition, p) result (f)
real(default) :: f
class(real_partition_fixed_order_t), intent(in) :: partition
type(vector4_t), intent(in), dimension(:) :: p
integer :: i
f = zero
do i = 1, size (partition%fks_pairs)
associate (ii => partition%fks_pairs(i)%ireg)
if ((p(ii(1)) + p(ii(2)))**1 < p(ii(1))**1 + p(ii(2))**1 + partition%scale) then
f = one
exit
end if
end associate
end do
end function real_partition_fixed_order_get_f
@ %def real_partition_fixed_order_get_f
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[real_subtraction_ut.f90]]>>=
<<File header>>
module real_subtraction_ut
use unit_tests
use real_subtraction_uti
<<Standard module head>>
<<Real subtraction: public test>>
contains
<<Real subtraction: test driver>>
end module real_subtraction_ut
@ %def real_subtraction_ut
@
<<[[real_subtraction_uti.f90]]>>=
<<File header>>
module real_subtraction_uti
<<Use kinds>>
use physics_defs
use lorentz
use numeric_utils
use real_subtraction
<<Standard module head>>
<<Real subtraction: test declarations>>
contains
<<Real subtraction: tests>>
end module real_subtraction_uti
@ %def real_subtraction_ut
@ API: driver for the unit tests below.
<<Real subtraction: public test>>=
public :: real_subtraction_test
<<Real subtraction: test driver>>=
subroutine real_subtraction_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Real subtraction: execute tests>>
end subroutine real_subtraction_test
@ %def real_subtraction_test
@ Test the final-state collinear subtraction.
<<Real subtraction: execute tests>>=
call test (real_subtraction_1, "real_subtraction_1", &
"final-state collinear subtraction", &
u, results)
<<Real subtraction: test declarations>>=
public :: real_subtraction_1
<<Real subtraction: tests>>=
subroutine real_subtraction_1 (u)
integer, intent(in) :: u
type(coll_subtraction_t) :: coll_sub
real(default) :: sqme_coll
type(vector4_t) :: p_res
type(vector4_t), dimension(5) :: p_born
real(default), dimension(4) :: k_perp
real(default), dimension(4,4) :: b_munu
integer :: mu, nu
real(default) :: born, born_c
integer, dimension(6) :: flst
p_born(1)%p = [500, 0, 0, 500]
p_born(2)%p = [500, 0, 0, -500]
p_born(3)%p = [3.7755E+02, 2.2716E+02, -95.4172, 2.8608E+02]
p_born(4)%p = [4.9529E+02, -2.739E+02, 84.8535, -4.0385E+02]
p_born(5)%p = [1.2715E+02, 46.7375, 10.5637, 1.1778E+02]
p_res = p_born(1) + p_born(2)
flst = [11, -11 , -2, 2, -2, 2]
b_munu(1, :) = [0., 0., 0., 0.]
b_munu(2, :) = [0., 1., 1., 1.]
b_munu(3, :) = [0., 1., 1., 1.]
b_munu(4, :) = [0., 1., 1., 1.]
k_perp = real_subtraction_compute_k_perp_fsr (p = p_born(5), phi = 0.5_default)
born = - b_munu(1, 1) + b_munu(2, 2) + b_munu(3, 3) + b_munu(4, 4)
born_c = 0.
do mu = 1, 4
do nu = 1, 4
born_c = born_c + k_perp(mu) * k_perp(nu) * b_munu(mu, nu)
end do
end do
write (u, "(A)") "* Test output: real_subtraction_1"
write (u, "(A)") "* Purpose: final-state collinear subtraction"
write (u, "(A)")
write (u, "(A, L1)") "* vanishing scalar-product of 3-momenta k_perp and p_born(emitter): ", &
nearly_equal (dot_product (p_born(5)%p(1:3), k_perp(2:4)), 0._default)
call coll_sub%init (n_alr = 1, n_in = 2)
call coll_sub%set_parameters (CA, CF, TR)
write (u, "(A)")
write (u, "(A)") "* g -> qq splitting"
write (u, "(A)")
sqme_coll = coll_sub%compute_fsr(5, flst, p_res, p_born, &
born, born_c, 0.5_default, 0.25_default, .false.)
write (u, "(A,F15.12)") "ME: ", sqme_coll
write (u, "(A)")
write (u, "(A)") "* g -> gg splitting"
write (u, "(A)")
b_munu(1, :) = [0., 0., 0., 0.]
b_munu(2, :) = [0., 0., 0., 1.]
b_munu(3, :) = [0., 0., 1., 1.]
b_munu(4, :) = [0., 0., 1., 1.]
k_perp = real_subtraction_compute_k_perp_fsr (p = p_born(5), phi = 0.5_default)
born = - b_munu(1, 1) + b_munu(2, 2) + b_munu(3, 3) + b_munu(4, 4)
born_c = 0.
do mu = 1, 4
do nu = 1, 4
born_c = born_c + k_perp(mu) * k_perp(nu) * b_munu(mu, nu)
end do
end do
flst = [11, -11, 2, -2, 21, 21]
sqme_coll = coll_sub%compute_fsr(5, flst, p_res, p_born, &
born, born_c, 0.5_default, 0.25_default, .true.)
write (u, "(A,F15.12)") "ME: ", sqme_coll
write (u, "(A)")
write (u, "(A)") "* Test output end: real_subtraction_1"
write (u, "(A)")
end subroutine real_subtraction_1
@ %def real_subtraction_1
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Combining the FKS Pieces}
<<[[nlo_data.f90]]>>=
<<File header>>
module nlo_data
<<Use kinds>>
<<Use strings>>
use diagnostics
use constants, only: zero
use string_utils, only: split_string, read_ival, string_contains_word
use io_units
use lorentz
use variables, only: var_list_t
use format_defs, only: FMT_15
use physics_defs, only: THR_POS_WP, THR_POS_WM
use physics_defs, only: THR_POS_B, THR_POS_BBAR
use physics_defs, only: NO_FACTORIZATION, FACTORIZATION_THRESHOLD
<<Standard module head>>
<<nlo data: public>>
<<nlo data: parameters>>
<<nlo data: types>>
<<nlo data: interfaces>>
contains
<<nlo data: procedures>>
end module nlo_data
@ %def nlo_data
@
<<nlo data: parameters>>=
integer, parameter, public :: FKS_DEFAULT = 1
integer, parameter, public :: FKS_RESONANCES = 2
integer, dimension(2), parameter, public :: ASSOCIATED_LEG_PAIR = [1, 3]
@ %def parameters
@
<<nlo data: public>>=
public :: fks_template_t
<<nlo data: types>>=
type :: fks_template_t
logical :: subtraction_disabled = .false.
integer :: mapping_type = FKS_DEFAULT
logical :: count_kinematics = .false.
real(default) :: fks_dij_exp1
real(default) :: fks_dij_exp2
real(default) :: xi_min
real(default) :: y_max
real(default) :: xi_cut, delta_o, delta_i
type(string_t), dimension(:), allocatable :: excluded_resonances
integer :: n_f
contains
<<nlo data: fks template: TBP>>
end type fks_template_t
@ %def fks_template_t
@
<<nlo data: fks template: TBP>>=
procedure :: write => fks_template_write
<<nlo data: procedures>>=
subroutine fks_template_write (template, unit)
class(fks_template_t), intent(in) :: template
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u,'(1x,A)') 'FKS Template: '
write (u,'(1x,A)', advance = 'no') 'Mapping Type: '
select case (template%mapping_type)
case (FKS_DEFAULT)
write (u,'(A)') 'Default'
case (FKS_RESONANCES)
write (u,'(A)') 'Resonances'
case default
write (u,'(A)') 'Unkown'
end select
write (u,'(1x,A,ES4.3,ES4.3)') 'd_ij exponentials: ', &
template%fks_dij_exp1, template%fks_dij_exp2
write (u, '(1x,A,ES4.3,ES4.3)') 'xi_cut: ', &
template%xi_cut
write (u, '(1x,A,ES4.3,ES4.3)') 'delta_o: ', &
template%delta_o
write (u, '(1x,A,ES4.3,ES4.3)') 'delta_i: ', &
template%delta_i
end subroutine fks_template_write
@ %def fks_template_write
@ Set FKS parameters. $\xi_{\text{cut}}, \delta_o$ and $\delta_{\mathrm{I}}$ steer the ratio of the integrated and real subtraction.
<<nlo data: fks template: TBP>>=
procedure :: set_parameters => fks_template_set_parameters
<<nlo data: procedures>>=
subroutine fks_template_set_parameters (template, exp1, exp2, xi_min, &
y_max, xi_cut, delta_o, delta_i)
class(fks_template_t), intent(inout) :: template
real(default), intent(in) :: exp1, exp2
real(default), intent(in) :: xi_min, y_max, &
xi_cut, delta_o, delta_i
template%fks_dij_exp1 = exp1
template%fks_dij_exp2 = exp2
template%xi_min = xi_min
template%y_max = y_max
template%xi_cut = xi_cut
template%delta_o = delta_o
template%delta_i = delta_i
end subroutine fks_template_set_parameters
@ %def fks_template_set_parameters
<<nlo data: fks template: TBP>>=
procedure :: set_mapping_type => fks_template_set_mapping_type
<<nlo data: procedures>>=
subroutine fks_template_set_mapping_type (template, val)
class(fks_template_t), intent(inout) :: template
integer, intent(in) :: val
template%mapping_type = val
end subroutine fks_template_set_mapping_type
@ %def fks_template_set_mapping_type
@
<<nlo data: fks template: TBP>>=
procedure :: set_counter => fks_template_set_counter
<<nlo data: procedures>>=
subroutine fks_template_set_counter (template)
class(fks_template_t), intent(inout) :: template
template%count_kinematics = .true.
end subroutine fks_template_set_counter
@ %def fks_template_set_counter
@
<<nlo data: public>>=
public :: real_scales_t
<<nlo data: types>>=
type :: real_scales_t
real(default) :: scale
real(default) :: ren_scale
real(default) :: fac_scale
real(default) :: scale_born
real(default) :: fac_scale_born
real(default) :: ren_scale_born
end type real_scales_t
@ %def real_scales_t
@
<<nlo data: public>>=
public :: get_threshold_momenta
<<nlo data: procedures>>=
function get_threshold_momenta (p) result (p_thr)
type(vector4_t), dimension(4) :: p_thr
type(vector4_t), intent(in), dimension(:) :: p
p_thr(1) = p(THR_POS_WP) + p(THR_POS_B)
p_thr(2) = p(THR_POS_B)
p_thr(3) = p(THR_POS_WM) + p(THR_POS_BBAR)
p_thr(4) = p(THR_POS_BBAR)
end function get_threshold_momenta
@ %def get_threshold_momenta
@
\subsection{Putting it together}
<<nlo data: public>>=
public :: nlo_settings_t
<<nlo data: types>>=
type :: nlo_settings_t
logical :: use_internal_color_correlations = .true.
logical :: use_internal_spin_correlations = .false.
logical :: use_resonance_mappings = .false.
logical :: combined_integration = .false.
logical :: fixed_order_nlo = .false.
logical :: test_soft_limit = .false.
logical :: test_coll_limit = .false.
logical :: test_anti_coll_limit = .false.
integer, dimension(:), allocatable :: selected_alr
integer :: factorization_mode = NO_FACTORIZATION
!!! Probably not the right place for this. Revisit after refactoring
real(default) :: powheg_damping_scale = zero
type(fks_template_t) :: fks_template
type(string_t) :: virtual_selection
logical :: virtual_resonance_aware_collinear = .true.
logical :: use_born_scale = .true.
logical :: cut_all_sqmes = .true.
type(string_t) :: nlo_correction_type
contains
<<nlo data: nlo settings: TBP>>
end type nlo_settings_t
@ %def nlo_settings_t
@
<<nlo data: nlo settings: TBP>>=
procedure :: init => nlo_settings_init
<<nlo data: procedures>>=
subroutine nlo_settings_init (nlo_settings, var_list, fks_template)
class(nlo_settings_t), intent(inout) :: nlo_settings
type(var_list_t), intent(in) :: var_list
type(fks_template_t), intent(in), optional :: fks_template
type(string_t) :: color_method
if (present (fks_template)) nlo_settings%fks_template = fks_template
color_method = var_list%get_sval (var_str ('$correlation_me_method'))
if (color_method == "") color_method = var_list%get_sval (var_str ('$method'))
nlo_settings%use_internal_color_correlations = color_method == 'omega' &
.or. color_method == 'threshold'
nlo_settings%combined_integration = var_list%get_lval &
(var_str ("?combined_nlo_integration"))
nlo_settings%fixed_order_nlo = var_list%get_lval &
(var_str ("?fixed_order_nlo_events"))
nlo_settings%test_soft_limit = var_list%get_lval (var_str ('?test_soft_limit'))
nlo_settings%test_coll_limit = var_list%get_lval (var_str ('?test_coll_limit'))
nlo_settings%test_anti_coll_limit = var_list%get_lval (var_str ('?test_anti_coll_limit'))
call setup_alr_selection ()
nlo_settings%virtual_selection = var_list%get_sval (var_str ('$virtual_selection'))
nlo_settings%virtual_resonance_aware_collinear = &
var_list%get_lval (var_str ('?virtual_collinear_resonance_aware'))
nlo_settings%powheg_damping_scale = &
var_list%get_rval (var_str ('powheg_damping_scale'))
nlo_settings%use_born_scale = &
var_list%get_lval (var_str ("?nlo_use_born_scale"))
nlo_settings%cut_all_sqmes = &
var_list%get_lval (var_str ("?nlo_cut_all_sqmes"))
nlo_settings%nlo_correction_type = var_list%get_sval (var_str ('$nlo_correction_type'))
contains
subroutine setup_alr_selection ()
type(string_t) :: alr_selection
type(string_t), dimension(:), allocatable :: alr_split
integer :: i, i1, i2
alr_selection = var_list%get_sval (var_str ('$select_alpha_regions'))
if (string_contains_word (alr_selection, var_str (","))) then
call split_string (alr_selection, var_str (","), alr_split)
allocate (nlo_settings%selected_alr (size (alr_split)))
do i = 1, size (alr_split)
nlo_settings%selected_alr(i) = read_ival(alr_split(i))
end do
else if (string_contains_word (alr_selection, var_str (":"))) then
call split_string (alr_selection, var_str (":"), alr_split)
if (size (alr_split) == 2) then
i1 = read_ival (alr_split(1))
i2 = read_ival (alr_split(2))
allocate (nlo_settings%selected_alr (i2 - i1 + 1))
do i = 1, i2 - i1 + 1
nlo_settings%selected_alr(i) = read_ival (alr_split(i))
end do
else
call msg_fatal ("select_alpha_regions: ':' specifies a range!")
end if
else if (len(alr_selection) == 1) then
allocate (nlo_settings%selected_alr (1))
nlo_settings%selected_alr(1) = read_ival (alr_selection)
end if
if (allocated (alr_split)) deallocate (alr_split)
end subroutine setup_alr_selection
end subroutine nlo_settings_init
@ %def nlo_settings_init
@
<<nlo data: nlo settings: TBP>>=
procedure :: write => nlo_settings_write
<<nlo data: procedures>>=
subroutine nlo_settings_write (nlo_settings, unit)
class(nlo_settings_t), intent(in) :: nlo_settings
integer, intent(in), optional :: unit
integer :: i, u
u = given_output_unit (unit); if (u < 0) return
write (u, '(A)') 'nlo_settings:'
write (u, '(3X,A,L1)') 'internal_color_correlations = ', &
nlo_settings%use_internal_color_correlations
write (u, '(3X,A,L1)') 'internal_spin_correlations = ', &
nlo_settings%use_internal_spin_correlations
write (u, '(3X,A,L1)') 'use_resonance_mappings = ', &
nlo_settings%use_resonance_mappings
write (u, '(3X,A,L1)') 'combined_integration = ', &
nlo_settings%combined_integration
write (u, '(3X,A,L1)') 'test_soft_limit = ', &
nlo_settings%test_soft_limit
write (u, '(3X,A,L1)') 'test_coll_limit = ', &
nlo_settings%test_coll_limit
write (u, '(3X,A,L1)') 'test_anti_coll_limit = ', &
nlo_settings%test_anti_coll_limit
if (allocated (nlo_settings%selected_alr)) then
write (u, '(3x,A)', advance = "no") 'selected alpha regions = ['
do i = 1, size (nlo_settings%selected_alr)
write (u, '(A,I0)', advance = "no") ",", nlo_settings%selected_alr(i)
end do
write (u, '(A)') "]"
end if
write (u, '(3X,A,' // FMT_15 // ')') 'powheg_damping_scale = ', &
nlo_settings%powheg_damping_scale
write (u, '(3X,A,A)') 'virtual_selection = ', &
char (nlo_settings%virtual_selection)
write (u, '(3X,A,A)') 'Real factorization mode = ', &
char (factorization_mode (nlo_settings%factorization_mode))
contains
function factorization_mode (fm)
type(string_t) :: factorization_mode
integer, intent(in) :: fm
select case (fm)
case (NO_FACTORIZATION)
factorization_mode = var_str ("None")
case (FACTORIZATION_THRESHOLD)
factorization_mode = var_str ("Threshold")
case default
factorization_mode = var_str ("Undefined!")
end select
end function factorization_mode
end subroutine nlo_settings_write
@ %def nlo_settings_write
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Contribution of divergencies due to PDF Evolution}
References:
\begin{itemize}
\item arXiv:hep-ph/9512328, (2.1)-(2.5), (4.29)-(4.53)
\item arXiv:0709.2092, (2.102)-(2.106)
\end{itemize}
The parton distrubition densities have to be evaluated at NLO, too.
The NLO PDF evolution is given by
\begin{equation}
\label{eqn:pdf_nlo}
f (\bar{x}) = \int_0^1 \int_0^1 dx dz f(x) \Gamma(z) \delta (\bar{x} - x z),
\end{equation}
where $\Gamma$ are the DGLAP evolution kernels for an $a \to d$ splitting,
\begin{equation}
\label{eqn:dglap}
\Gamma_a^{(d)} = \delta_{ad}\delta(1-x) - \frac{\alpha_s}{2\pi} \left(\frac{1}{\epsilon} P_{ad}(x,0) - K_{ad}(x)\right) + \mathcal{O}(\alpha_s).
\end{equation}
$K_{ad}$ is a renormalization scheme matching factor, which is exactly zero in $\overline{\text{MS}}$.
Let the leading-order hadronic cross section be given by
\begin{equation}
\label{eqn:xsec_hadro_lo}
d\sigma^{(0)}(s) = \int dx_\oplus dx_\ominus f_\oplus (x_\oplus) f_\ominus (x_\ominus) d\tilde{\sigma}^{(0)} (x_\oplus x_\ominus s),
\end{equation}
then the NLO hadronic cross section is
\begin{equation}
\label{eqn:xsec_hadro_nlo}
d\sigma^{(1)}(s) = \int dx_\oplus dx_\ominus dz_\oplus dz_\ominus f_\oplus (x_\oplus) f_\ominus (x_\ominus)
\underbrace{\Gamma_\oplus (z_\oplus) \Gamma_\ominus (z_\ominus) d\tilde{\sigma}^{(1)} (z_\oplus z_\ominus s)}_{d\hat{\sigma}^{(1)}}.
\end{equation}
$d\hat{\sigma}$ is called the subtracted partonic cross section. Expanding in $\alpha_s$ we find
\begin{align}
d\hat{\sigma}^{(0)}_{ab}(k_1, k_2) &= d\tilde{\sigma}_{ab}^{(0)} (k_1, k_2), \\
d\hat{\sigma}^{(1)}_{ab}(k_1, k_2) &= d\tilde{\sigma}_{ab}^{(1)} (k_1, k_2) \\
&+ \frac{\alpha_s}{2\pi} \sum_d \int dx \left (\frac{1}{\epsilon} P_{da}(x,0) - K_{da}(x)\right) d\tilde{\sigma}_{db}^{(0)}(xk_1, k_2)\\
&+ \frac{\alpha_s}{2\pi} \sum_d \int \left (\frac{1}{\epsilon} P_{db} (x, 0) - K_{db}(x)\right) d\tilde{\sigma}_{ad}^{(0)}(k_1, xk_2).\\
&= d\tilde{\sigma}_{ab}^{(1)} + d\tilde{\sigma}_{ab}^{(cnt,+)} + d\tilde{\sigma}_{ab}^{(cnt,-)}
\end{align}
Let us now turn the soft-subtracted real part of the cross section. For ease of notation, it is constrained to one singular region,
\begin{align*}
\label{eqn:R-in}
d\sigma^{(in)}_\alpha &= \left[\left(\frac{1}{\xi}\right)_{c} - 2\epsilon\left(\frac{\log \xi}{\xi}\right)_{c}\right] (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha \\
&\times \frac{1}{2(2\pi)^{3-2\epsilon}} \left(\frac{\sqrt{s}}{2}\right)^{2-2\epsilon} \left( 1 - y^2\right)^{-1-\epsilon} d\phi d\xi dy d\Omega^{2-2\epsilon},
\end{align*}
where we regularize collinear divergencies using the identity
\begin{equation*}
\left (1 - y^2 \right)^{-1-\epsilon} = -\frac{2^{-\epsilon}}{\epsilon} \left (\delta(1-y) + \delta(1+y)\right)
+ \underbrace{\frac{1}{2} \left[ \left (\frac {1}{1-y}\right)_{c} + \left (\frac{1}{1+y}\right)_{c} \right]}_{\mathcal{P}(y)}.
\end{equation*}
This enables us to split the cross section into a finite and a singular part. The latter can further be separated into a contribution of the incoming and of the outgoing particles,
\begin{equation*}
d\sigma^{(in)}_\alpha = d\sigma^{(in,+)}_\alpha + d\sigma^{(in,-)}_\alpha + d\sigma^{(in,f)}_\alpha.
\end{equation*}
They are given by
\begin{align}
\label{eqn:sigma-f}
d\sigma^{(in,f)}_\alpha = & \mathcal{P}(y) \left[\left(\frac{1}{\xi}\right)_{c} - 2\epsilon \left(\frac{\log\xi}{\xi}\right)_{c}\right] \frac{1}{2(2\pi)^{3-2\epsilon}}
\left(\frac{\sqrt{s}}{2}\right)^{2-2\epsilon} \\
& \times (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy d\Omega^{2-2\epsilon}
\end{align}
and
\begin{align}
\label{eqn:sigma-pm}
d\sigma^{(in,\pm)}_\alpha &= -\frac{2^{-\epsilon}}{\epsilon} \delta (1 \mp y) \left[ \left( \frac{1}{\xi}\right)_{c} - 2\epsilon \left(\frac{\log\xi}{\xi}\right)_{c}\right] \\
& \times \frac{1}{2(2\pi)^{3-2\epsilon}} \left( \frac{\sqrt{s}}{2}\right)^{2-2\epsilon} (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy d\Omega^{2-2\epsilon}.
\end{align}
Equation \ref{eqn:sigma-f} is the contribution to the real cross section which is computed in [[evaluate_region_isr]]. It is regularized both in the soft and collinear limit via the plus distributions.
Equation \ref{eqn:sigma-pm} is a different contribution. It is only present exactly in the collinear limit, due to the delta function. The divergences present in this term do not completely cancel out
divergences in the virtual matrix element, because the beam axis is distinguished. Thus, the conditions in which the KLM theorem applies are not met. To see this, we carry out the collinear limit, obtaining
\begin{equation*}
\lim_{y \to 1} (1-y^2)\xi^2\mathcal{R}_\alpha = 8\pi\alpha_s \mu^{2\epsilon} \left(\frac{2}{\sqrt{s}}\right)^2 \xi P^<(1-\xi, \epsilon) \mathcal{R}_\alpha,
\end{equation*}
with the Altarelli-Parisi splitting kernel for $z < 1$, $P^<(z,\epsilon)$. Moreover, $\lim_{\vec{k} \parallel \vec{k}_1} d\phi = d\phi_3$ violates spatial averaging. The integration over the spherical angle $d\Omega$ can be carried out easily, yielding a factor of $2\pi^{1-\epsilon} / \Gamma(1-\epsilon)$.
This allows us to redefine $\epsilon$,
\begin{equation}
\frac{1}{\epsilon} - \gamma_E + \log(4\pi) \to \frac{1}{\epsilon}.
\end{equation}
In order to make a connection to $d\tilde{\sigma}^{(cnt,\pm)}$, we relate $P_{ab}(z,0)$ to $P^<_{ab}(z,0)$ via the equation
\begin{equation*}
P_{ab}(z,0) = (1-z)P_{ab}^<(z,0)\left(\frac{1}{1-z}\right)_+ + \gamma(a)\delta_{ab}\delta(1-z),
\end{equation*}
which yields
\begin{equation} \label{eqn:sigma-cnt}
d\tilde{\sigma}^{(cnt,+)} = \frac{\alpha_s}{2\pi} \sum_d \left\lbrace -K_{da}(1-\xi) + \frac{1}{\epsilon} \left[\left(\frac{1}{\xi}\right)_+ \xi P_{da}^<(1-\xi,0)
+ \delta_{da}\delta(\xi)\gamma(d)\right]\right\rbrace \mathcal{R}_\alpha \mathcal{S}_\alpha.
\end{equation}
This term has the same pole structure as eqn. \ref{eqn:sigma-pm}. This makes clear that the quantity
\begin{equation}
d\hat{\sigma}^{(in,+)} = d\tilde{\sigma}^{(in,+)} + \frac{1}{4} d\tilde{\sigma}^{(cnt,+)}
\end{equation}
has no collinear poles. Therefore, our task is to add up eqns. \ref{eqn:sigma-pm} and \ref{eqn:sigma-cnt} in order to compute the finite remainder. This is the integrand which is evaluated in the [[dglap_remnant]] component.\\
So, we have to perform an expansion of $d\hat{\sigma}^{(in,+)}$ in $\epsilon$. Hereby, we must not neglect the implicit $\epsilon$-dependence of $P^<$, which leads to additional terms involving the
first derivative,
\begin{equation*}
P_{ab}^<(z,\epsilon) = P_{ab}^<(z,0) + \epsilon \frac{\partial P_{ab}^<(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} + \mathcal{O}(\alpha_s^2).
\end{equation*}
This finally gives us the equation for the collinear remnant. Note that there is still one soft $1/\epsilon$-pole, which cancels out with the corresponding expression in the soft-virtual terms.
\begin{align}
d\hat{\sigma}^{(in,+)} &= \frac{\alpha_s}{2\pi} \frac{1}{\epsilon} \gamma(a) \mathcal{R}_\alpha \mathcal{S}_\alpha \nonumber\\
&+ \frac{\alpha_s}{2\pi} \sum_d \left\lbrace (1-z) P_{da}^<(z,0)\left[\left(\frac{1}{1-z}\right)_{c} \log\frac{s\delta_{\mathrm{I}}}{2\mu^2} + 2 \left(\frac{\log(1-z)}{1-z}\right)_{c}\right] \right. \nonumber\\
&\left . -(1-z)\frac{\partial P_{da}^<(z,\epsilon)}{\partial \epsilon} \left(\frac{1}{1-z}\right)_{c} - K_{da}(z)\right\rbrace \mathcal{R}_\alpha \mathcal{S}_\alpha
\end{align}
<<[[dglap_remnant.f90]]>>=
<<File header>>
module dglap_remnant
<<Use kinds with double>>
<<Use strings>>
use numeric_utils
use diagnostics
use constants
use physics_defs
use pdg_arrays
use phs_fks, only: isr_kinematics_t
use nlo_data
<<Standard module head>>
<<dglap remnant: public>>
<<dglap remnant: types>>
contains
<<dglap remnant: procedures>>
end module dglap_remnant
@ %def module dglap_remnant
@
<<dglap remnant: public>>=
public :: dglap_remnant_t
<<dglap remnant: types>>=
type :: dglap_remnant_t
type(nlo_settings_t), pointer :: settings => null ()
type(isr_kinematics_t), pointer :: isr_kinematics => null ()
integer, dimension(:), allocatable :: light_quark_flv
integer, dimension(:,:), allocatable :: flv_in
real(default), dimension(:), allocatable :: sqme_born
real(default), dimension(:,:,:), allocatable :: sqme_coll_isr
integer :: n_flv
contains
<<dglap remnant: dglap remnant: TBP>>
end type dglap_remnant_t
@ %def dglap_remnant_t
@
<<dglap remnant: dglap remnant: TBP>>=
procedure :: init => dglap_remnant_init
<<dglap remnant: procedures>>=
subroutine dglap_remnant_init (dglap, settings, n_flv_born, isr_kinematics, flv, n_alr)
class(dglap_remnant_t), intent(inout) :: dglap
type(nlo_settings_t), intent(in), target :: settings
integer, intent(in) :: n_flv_born
type(isr_kinematics_t), intent(in), target :: isr_kinematics
integer, dimension(:,:), intent(in) :: flv
integer, intent(in) :: n_alr
integer :: i, j, n_quarks
logical, dimension(-6:6) :: quark_checked
dglap%settings => settings
quark_checked = .false.
allocate (dglap%sqme_born(n_flv_born))
dglap%sqme_born = zero
allocate (dglap%sqme_coll_isr(2, 2, n_flv_born))
dglap%sqme_coll_isr = zero
dglap%isr_kinematics => isr_kinematics
dglap%n_flv = size (flv, dim=2)
allocate (dglap%flv_in (2, dglap%n_flv))
dglap%flv_in = flv
n_quarks = 0
do i = 1, size (flv, dim = 1)
if (is_quark(flv(i,1))) then
n_quarks = n_quarks + 1
quark_checked(flv(i, 1)) = .true.
end if
end do
allocate (dglap%light_quark_flv (n_quarks))
j = 1
do i = -6, 6
if (quark_checked(i)) then
dglap%light_quark_flv(j) = i
j = j + 1
end if
end do
end subroutine dglap_remnant_init
@ %def dglap_remnant_init
@
<<dglap remnant: dglap remnant: TBP>>=
procedure :: get_pdf_singlet => dglap_remnant_get_pdf_singlet
<<dglap remnant: procedures>>=
function dglap_remnant_get_pdf_singlet (dglap, emitter) result (sum_sqme)
real(default) :: sum_sqme
class(dglap_remnant_t), intent(in) :: dglap
integer, intent(in) :: emitter
integer :: i_flv
integer, parameter :: PDF_SINGLET = 2
sum_sqme = zero
do i_flv = 1, size (dglap%sqme_coll_isr, dim=3)
if (any (dglap%flv_in(emitter, i_flv) == dglap%light_quark_flv)) &
sum_sqme = sum_sqme + dglap%sqme_coll_isr (emitter, PDF_SINGLET, i_flv)
end do
end function dglap_remnant_get_pdf_singlet
@ %def dglap_remnant_get_summed_quark_sqmes
@ Evaluates formula (...). Note that, as also is the case for the real subtraction,
we have to take into account an additional term, occuring because the integral the
plus distribution is evaluated over is not constrained on the interval $[0,1]$.
Explicitly, this means (see JHEP 06(2010)043, (4.11)-(4.12))
\begin{align}
\int_{\bar{x}_\oplus}^1 dz \left( \frac{1}{1-z} \right)_{\xi_{\text{cut}}} & = \log \frac{1-\bar{x}_\oplus}{\xi_{\text{cut}}} f(1) + \int_{\bar{x}_\oplus}^1 \frac{f(z) - f(1)}{1-z}, \\
\int_{\bar{x}_\oplus}^1 dz \left(\frac{\log(1-z)}{1-z}\right)_{\xi_{\text{cut}}} f(z) & = \frac{1}{2}\left( \log^2(1-\bar{x}_\oplus) - \log^2 (\xi_{\text{cut}}) \right)f(1) + \int_{\bar{x}_\oplus}^1 \frac{\log(1-z)[f(z) - f(1)]}{1-z},
\end{align}
and the same of course for $\bar{x}_\ominus$. These two terms are stored in the [[plus_dist_remnant]] variable below.
<<dglap remnant: dglap remnant: TBP>>=
procedure :: evaluate => dglap_remnant_evaluate
<<dglap remnant: procedures>>=
subroutine dglap_remnant_evaluate (dglap, alpha_s, separate_alrs, sqme_dglap)
class(dglap_remnant_t), intent(inout) :: dglap
real(default), intent(in) :: alpha_s
logical, intent(in) :: separate_alrs
real(default), intent(inout), dimension(:) :: sqme_dglap
real(default) :: factor, factor_soft, plus_dist_remnant
integer :: i_flv, ii_flv, emitter
real(default), dimension(2) :: tmp
real(default) :: sb, xb, onemz
real(default) :: fac_scale2, jac
real(default) :: sqme_scaled
integer, parameter :: PDF = 1, PDF_SINGLET = 2
sb = dglap%isr_kinematics%sqrts_born**2
fac_scale2 = dglap%isr_kinematics%fac_scale**2
do i_flv = 1, dglap%n_flv
if (separate_alrs) then
ii_flv = i_flv
else
ii_flv = 1
end if
tmp = zero
do emitter = 1, 2
associate (z => dglap%isr_kinematics%z(emitter), template => dglap%settings%fks_template)
jac = dglap%isr_kinematics%jacobian(emitter)
onemz = one - z
factor = log (sb * template%delta_i / two / z / fac_scale2) / &
onemz + two * log (onemz) / onemz
factor_soft = log (sb * template%delta_i / two / fac_scale2) / &
onemz + two * log (onemz) / onemz
xb = dglap%isr_kinematics%x(emitter)
plus_dist_remnant = log ((one - xb) / template%xi_cut) * log (sb * template%delta_i / &
two / fac_scale2) + (log (one - xb)**2 - log (template%xi_cut)**2)
if (is_gluon(dglap%flv_in(emitter, i_flv))) then
sqme_scaled = dglap%sqme_coll_isr(emitter, PDF, i_flv)
tmp(emitter) = p_hat_gg(z) * factor / z * sqme_scaled * jac &
- p_hat_gg(one) * factor_soft * dglap%sqme_born(i_flv) * jac &
+ p_hat_gg(one) * plus_dist_remnant * dglap%sqme_born(i_flv)
tmp(emitter) = tmp(emitter) + &
(p_hat_qg(z) * factor - p_derived_qg(z)) / z * jac * &
dglap%get_pdf_singlet (emitter)
else if (is_quark(dglap%flv_in(emitter, i_flv))) then
sqme_scaled = dglap%sqme_coll_isr(emitter, PDF, i_flv)
tmp(emitter) = p_hat_qq(z) * factor / z * sqme_scaled * jac &
- p_derived_qq(z) / z * sqme_scaled * jac &
- p_hat_qq(one) * factor_soft * dglap%sqme_born(i_flv) * jac &
+ p_hat_qq(one) * plus_dist_remnant * dglap%sqme_born(i_flv)
sqme_scaled = dglap%sqme_coll_isr(emitter, PDF_SINGLET, i_flv)
tmp(emitter) = tmp(emitter) + &
(p_hat_gq(z) * factor - p_derived_gq(z)) / z * sqme_scaled * jac
end if
end associate
end do
sqme_dglap(ii_flv) = sqme_dglap(ii_flv) + alpha_s / twopi * (tmp(1) + tmp(2))
end do
contains
<<dglap remnant: dglap remnant evaluate: procedures>>
end subroutine dglap_remnant_evaluate
@ %def dglap_remnant_evaluate
@ We introduce $\hat{P}(z, \epsilon) = (1 - z) P(z, \epsilon)$ and have
\begin{align}
\hat{P}^{gg}(z) & = 2C_A \left[z + \frac{(1-z)^2}{z} + z(1-z)^2\right], \\
\hat{P}^{qg}(z) & = C_F (1-z) \frac{1 + (1-z)^2}{z}, \\
\hat{P}^{gq}(z) & = T_F (1 - z - 2z(1-z)^2), \\
\hat{P}^{qq}(z) & = C_F (1 + z^2).
\end{align}
<<dglap remnant: dglap remnant evaluate: procedures>>=
function p_hat_gg (z)
real(default) :: p_hat_gg
<<p variables>>
p_hat_gg = two * CA * (z + onemz**2 / z + z * onemz**2)
end function p_hat_gg
function p_hat_qg (z)
real(default) :: p_hat_qg
<<p variables>>
p_hat_qg = CF * onemz / z * (one + onemz**2)
end function p_hat_qg
function p_hat_gq (z)
real(default) :: p_hat_gq
<<p variables>>
p_hat_gq = TR * (onemz - two * z * onemz**2)
end function p_hat_gq
function p_hat_qq (z)
real(default) :: p_hat_qq
real(default), intent(in) :: z
p_hat_qq = CF * (one + z**2)
end function p_hat_qq
@ %def p_hat_qq, p_hat_gq, p_hat_qg, p_hat_gg
@
\begin{align}
\frac{\partial P^{gg}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = 0, \\
\frac{\partial P^{qg}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -C_F z, \\
\frac{\partial P^{gq}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -
2 T_F z (1-z), \\
\frac{\partial P^{gq}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -C_F (1-z).\\
\end{align}
<<dglap remnant: dglap remnant evaluate: procedures>>=
function p_derived_gg (z)
real(default) :: p_derived_gg
real(default), intent(in) :: z
p_derived_gg = zero
end function p_derived_gg
function p_derived_qg (z)
real(default) :: p_derived_qg
real(default), intent(in) :: z
p_derived_qg = -CF * z
end function p_derived_qg
function p_derived_gq (z)
real(default) :: p_derived_gq
<<p variables>>
p_derived_gq = -two * TR * z * onemz
end function p_derived_gq
function p_derived_qq (z)
real(default) :: p_derived_qq
<<p variables>>
p_derived_qq = -CF * onemz
end function p_derived_qq
@ %def p_derived_gg, p_derived_qg, p_derived_gq, p_derived_qq
@
<<p variables>>=
real(default), intent(in) :: z
real(default) :: onemz
onemz = one - z
@ %def variables
@
<<dglap remnant: dglap remnant: TBP>>=
procedure :: final => dglap_remnant_final
<<dglap remnant: procedures>>=
subroutine dglap_remnant_final (dglap)
class(dglap_remnant_t), intent(inout) :: dglap
if (associated (dglap%isr_kinematics)) nullify (dglap%isr_kinematics)
if (allocated (dglap%light_quark_flv)) deallocate (dglap%light_quark_flv)
if (allocated (dglap%sqme_born)) deallocate (dglap%sqme_born)
if (allocated (dglap%sqme_coll_isr)) deallocate (dglap%sqme_coll_isr)
end subroutine dglap_remnant_final
@ %def dglap_remnant_final
@
\subsection{Rescaling function}
NLO applications require that the beam energy fractions
can be recomputed flexibly for different components of
the calculation, e.g. in the collinear subtraction. To
deal with this, we use a rescaling function which is given
to [[sf_int_apply]] as an optional argument to use a different
set of [[x]] values.
<<[[isr_collinear.f90]]>>=
<<File header>>
module isr_collinear
<<Use kinds with double>>
<<Use strings>>
use diagnostics
use constants, only: one, two
use physics_defs, only: n_beam_structure_int
use sf_base, only: sf_rescale_t
<<Standard module head>>
<<isr collinear: public>>
<<isr collinear: types>>
contains
<<isr collinear: procedures>>
end module isr_collinear
@ %def module isr_collinear
<<isr collinear: public>>=
public :: sf_rescale_collinear_t
<<isr collinear: types>>=
type, extends (sf_rescale_t) :: sf_rescale_collinear_t
real(default) :: xi_tilde
contains
<<isr collinear: rescale collinear: TBP>>
end type sf_rescale_collinear_t
@ %def sf_rescale_collinear_t
@
<<isr collinear: rescale collinear: TBP>>=
procedure :: apply => sf_rescale_collinear_apply
<<isr collinear: procedures>>=
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: ', 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 *, 'scaled x: ', x
end subroutine sf_rescale_collinear_apply
@ %def sf_rescale_collinear_apply
@
<<isr collinear: rescale collinear: TBP>>=
procedure :: set => sf_rescale_collinear_set
<<isr collinear: procedures>>=
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
@
<<isr collinear: public>>=
public :: sf_rescale_real_t
<<isr collinear: types>>=
type, extends (sf_rescale_t) :: sf_rescale_real_t
real(default) :: xi, y
contains
<<isr collinear: rescale real: TBP>>
end type sf_rescale_real_t
@ %def sf_rescale_real_t
@
<<isr collinear: rescale real: TBP>>=
procedure :: apply => sf_rescale_real_apply
<<isr collinear: procedures>>=
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: ', 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 *, 'scaled x: ', x
end subroutine sf_rescale_real_apply
@ %def sf_rescale_real_apply
@
<<isr collinear: rescale real: TBP>>=
procedure :: set => sf_rescale_real_set
<<isr collinear: procedures>>=
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
<<isr collinear: public>>=
public :: sf_rescale_dglap_t
<<isr collinear: types>>=
type, extends(sf_rescale_t) :: sf_rescale_dglap_t
real(default), dimension(:), allocatable :: z
contains
<<isr collinear: rescale dglap: TBP>>
end type sf_rescale_dglap_t
@ %def sf_rescale_dglap_t
@
<<isr collinear: rescale dglap: TBP>>=
procedure :: apply => sf_rescale_dglap_apply
<<isr collinear: procedures>>=
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
@
<<isr collinear: rescale dglap: TBP>>=
procedure :: set => sf_rescale_dglap_set
<<isr collinear: procedures>>=
subroutine sf_rescale_dglap_set (func, z)
class(sf_rescale_dglap_t), intent(inout) :: func
real(default), dimension(:), intent(in) :: z
! allocate-on-assginment
func%z = z
end subroutine sf_rescale_dglap_set
@ %def sf_rescale_dglap_set
@
\section{Dispatch}
@
<<[[dispatch_fks.f90]]>>=
<<File header>>
module dispatch_fks
<<Use kinds>>
<<Use strings>>
use string_utils, only: split_string
use variables, only: var_list_t
use nlo_data, only: fks_template_t, FKS_DEFAULT, FKS_RESONANCES
<<Standard module head>>
<<Dispatch fks: public>>
contains
<<Dispatch fks: procedures>>
end module dispatch_fks
@ %def dispatch_fks
@ Initialize parameters used to optimize FKS calculations.
<<Dispatch fks: public>>=
public :: dispatch_fks_s
<<Dispatch fks: procedures>>=
subroutine dispatch_fks_s (fks_template, var_list)
type(fks_template_t), intent(inout) :: fks_template
type(var_list_t), intent(in) :: var_list
real(default) :: fks_dij_exp1, fks_dij_exp2
type(string_t) :: fks_mapping_type
logical :: subtraction_disabled
type(string_t) :: exclude_from_resonance
fks_dij_exp1 = &
var_list%get_rval (var_str ("fks_dij_exp1"))
fks_dij_exp2 = &
var_list%get_rval (var_str ("fks_dij_exp2"))
fks_mapping_type = &
var_list%get_sval (var_str ("$fks_mapping_type"))
subtraction_disabled = &
var_list%get_lval (var_str ("?disable_subtraction"))
exclude_from_resonance = &
var_list%get_sval (var_str ("$resonances_exclude_particles"))
if (exclude_from_resonance /= var_str ("default")) &
call split_string (exclude_from_resonance, var_str (":"), &
fks_template%excluded_resonances)
call fks_template%set_parameters ( &
exp1 = fks_dij_exp1, exp2 = fks_dij_exp2, &
xi_min = var_list%get_rval (var_str ("fks_xi_min")), &
y_max = var_list%get_rval (var_str ("fks_y_max")), &
xi_cut = var_list%get_rval (var_str ("fks_xi_cut")), &
delta_o = var_list%get_rval (var_str ("fks_delta_o")), &
delta_i = var_list%get_rval (var_str ("fks_delta_i")))
select case (char (fks_mapping_type))
case ("default")
call fks_template%set_mapping_type (FKS_DEFAULT)
case ("resonances")
call fks_template%set_mapping_type (FKS_RESONANCES)
end select
fks_template%subtraction_disabled = subtraction_disabled
fks_template%n_f = var_list%get_ival (var_str ("alphas_nf"))
end subroutine dispatch_fks_s
@ %def dispatch_fks_s
@
Index: trunk/src/utilities/utilities.nw
===================================================================
--- trunk/src/utilities/utilities.nw (revision 8249)
+++ trunk/src/utilities/utilities.nw (revision 8250)
@@ -1,1270 +1,1264 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: Utilities
\chapter{Utilities}
\includemodulegraph{utilities}
These modules are intended as part of WHIZARD, but in fact they are
generic and could be useful for any purpose.
The modules depend only on modules from the [[basics]] set.
\begin{description}
\item[file\_utils]
Procedures that deal with external files, if not covered by Fortran
built-ins.
\item[file\_registries]
Manage files that are accessed by their name.
\item[string\_utils]
Some string-handling utilities. Includes conversion to C string.
\item[format\_utils]
Utilities for pretty-printing.
\item[format\_defs]
Predefined format strings.
\item[numeric\_utils]
Utilities for comparing numerical values.
\end{description}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{File Utilities}
This module provides miscellaneous tools associated with named
external files. Currently only:
\begin{itemize}
\item
Delete a named file
\end{itemize}
<<[[file_utils.f90]]>>=
<<File header>>
module file_utils
use io_units
<<Standard module head>>
<<File utils: public>>
contains
<<File utils: procedures>>
end module file_utils
@ %def file_utils
@
\subsection{Deleting a file}
Fortran does not contain a command for deleting a file. Here, we
provide a subroutine that deletes a file if it exists. We do not
handle the subtleties, so we assume that it is writable if it exists.
<<File utils: public>>=
public :: delete_file
<<File utils: procedures>>=
subroutine delete_file (name)
character(*), intent(in) :: name
logical :: exist
integer :: u
inquire (file = name, exist = exist)
if (exist) then
u = free_unit ()
open (unit = u, file = name)
close (u, status = "delete")
end if
end subroutine delete_file
@ %def delete_file
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{File Registries}
This module provides a file-registry facility. We can open and close
files multiple times without inadvertedly accessing a single file by two
different I/O unit numbers. Opening a file the first time enters it
into the registry. Opening again just returns the associated I/O
unit. The registry maintains a reference count, so closing a file
does not actually complete until the last reference is released.
File access will always be sequential, however. The file can't be
opened at different positions simultaneously.
<<[[file_registries.f90]]>>=
<<File header>>
module file_registries
<<Use strings>>
use io_units
<<Standard module head>>
<<File registries: public>>
<<File registries: types>>
contains
<<File registries: procedures>>
end module file_registries
@ %def file_registries
@
\subsection{File handle}
This object holds a filename (fully qualified), the associated
unit, and a reference count. The idea is that the object should be
deleted when the reference count drops to zero.
<<File registries: types>>=
type :: file_handle_t
type(string_t) :: file
integer :: unit = 0
integer :: refcount = 0
contains
<<File registries: file handle: TBP>>
end type file_handle_t
@ %def file_handle_t
@ Debugging output:
<<File registries: file handle: TBP>>=
procedure :: write => file_handle_write
<<File registries: procedures>>=
subroutine file_handle_write (handle, u, show_unit)
class(file_handle_t), intent(in) :: handle
integer, intent(in) :: u
logical, intent(in), optional :: show_unit
logical :: show_u
show_u = .false.; if (present (show_unit)) show_u = show_unit
if (show_u) then
write (u, "(3x,A,1x,I0,1x,'(',I0,')')") &
char (handle%file), handle%unit, handle%refcount
else
write (u, "(3x,A,1x,'(',I0,')')") &
char (handle%file), handle%refcount
end if
end subroutine file_handle_write
@ %def file_handle_write
@ Initialize with a file name, don't open the file yet:
<<File registries: file handle: TBP>>=
procedure :: init => file_handle_init
<<File registries: procedures>>=
subroutine file_handle_init (handle, file)
class(file_handle_t), intent(out) :: handle
type(string_t), intent(in) :: file
handle%file = file
end subroutine file_handle_init
@ %def file_handle_init
@ We check the [[refcount]] before actually opening the file.
<<File registries: file handle: TBP>>=
procedure :: open => file_handle_open
<<File registries: procedures>>=
subroutine file_handle_open (handle)
class(file_handle_t), intent(inout) :: handle
if (handle%refcount == 0) then
handle%unit = free_unit ()
open (unit = handle%unit, file = char (handle%file), action = "read", &
status = "old")
end if
handle%refcount = handle%refcount + 1
end subroutine file_handle_open
@ %def file_handle_open
@ Analogously, close if the refcount drops to zero. The caller may
then delete the object.
<<File registries: file handle: TBP>>=
procedure :: close => file_handle_close
<<File registries: procedures>>=
subroutine file_handle_close (handle)
class(file_handle_t), intent(inout) :: handle
handle%refcount = handle%refcount - 1
if (handle%refcount == 0) then
close (handle%unit)
handle%unit = 0
end if
end subroutine file_handle_close
@ %def file_handle_close
@ The I/O unit will be nonzero when the file is open.
<<File registries: file handle: TBP>>=
procedure :: is_open => file_handle_is_open
<<File registries: procedures>>=
function file_handle_is_open (handle) result (flag)
class(file_handle_t), intent(in) :: handle
logical :: flag
flag = handle%unit /= 0
end function file_handle_is_open
@ %def file_handle_is_open
@ Return the filename, so we can identify the entry.
<<File registries: file handle: TBP>>=
procedure :: get_file => file_handle_get_file
<<File registries: procedures>>=
function file_handle_get_file (handle) result (file)
class(file_handle_t), intent(in) :: handle
type(string_t) :: file
file = handle%file
end function file_handle_get_file
@ %def file_handle_get_file
@ For debugging, return the I/O unit number.
<<File registries: file handle: TBP>>=
procedure :: get_unit => file_handle_get_unit
<<File registries: procedures>>=
function file_handle_get_unit (handle) result (unit)
class(file_handle_t), intent(in) :: handle
integer :: unit
unit = handle%unit
end function file_handle_get_unit
@ %def file_handle_get_unit
@
\subsection{File handles registry}
This is implemented as a doubly-linked list. The list exists only
once in the program, as a private module variable.
Extend the handle type to become a list entry:
<<File registries: types>>=
type, extends (file_handle_t) :: file_entry_t
type(file_entry_t), pointer :: prev => null ()
type(file_entry_t), pointer :: next => null ()
end type file_entry_t
@ %def file_entry_t
@ The actual registry. We need only the pointer to the first entry.
<<File registries: public>>=
public :: file_registry_t
<<File registries: types>>=
type :: file_registry_t
type(file_entry_t), pointer :: first => null ()
contains
<<File registries: file registry: TBP>>
end type file_registry_t
@ %def file_registry_t
@ Debugging output.
<<File registries: file registry: TBP>>=
procedure :: write => file_registry_write
<<File registries: procedures>>=
subroutine file_registry_write (registry, unit, show_unit)
class(file_registry_t), intent(in) :: registry
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_unit
type(file_entry_t), pointer :: entry
integer :: u
u = given_output_unit (unit)
if (associated (registry%first)) then
write (u, "(1x,A)") "File registry:"
entry => registry%first
do while (associated (entry))
call entry%write (u, show_unit)
entry => entry%next
end do
else
write (u, "(1x,A)") "File registry: [empty]"
end if
end subroutine file_registry_write
@ %def file_registry_write
@ Open a file: find the appropriate entry. Create a new entry and add
to the list if necessary. The list is extended at the beginning.
Return the I/O unit number for the records.
<<File registries: file registry: TBP>>=
procedure :: open => file_registry_open
<<File registries: procedures>>=
subroutine file_registry_open (registry, file, unit)
class(file_registry_t), intent(inout) :: registry
type(string_t), intent(in) :: file
integer, intent(out), optional :: unit
type(file_entry_t), pointer :: entry
entry => registry%first
FIND_ENTRY: do while (associated (entry))
if (entry%get_file () == file) exit FIND_ENTRY
entry => entry%next
end do FIND_ENTRY
if (.not. associated (entry)) then
allocate (entry)
call entry%init (file)
if (associated (registry%first)) then
registry%first%prev => entry
entry%next => registry%first
end if
registry%first => entry
end if
call entry%open ()
if (present (unit)) unit = entry%get_unit ()
end subroutine file_registry_open
@ %def file_registry_open
@ Close a file: find the appropriate entry. Delete the entry if there
is no file connected to it anymore.
<<File registries: file registry: TBP>>=
procedure :: close => file_registry_close
<<File registries: procedures>>=
subroutine file_registry_close (registry, file)
class(file_registry_t), intent(inout) :: registry
type(string_t), intent(in) :: file
type(file_entry_t), pointer :: entry
entry => registry%first
FIND_ENTRY: do while (associated (entry))
if (entry%get_file () == file) exit FIND_ENTRY
entry => entry%next
end do FIND_ENTRY
if (associated (entry)) then
call entry%close ()
if (.not. entry%is_open ()) then
if (associated (entry%prev)) then
entry%prev%next => entry%next
else
registry%first => entry%next
end if
if (associated (entry%next)) then
entry%next%prev => entry%prev
end if
deallocate (entry)
end if
end if
end subroutine file_registry_close
@ %def file_registry_close
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{String Utilities}
This module provides tools associated with strings
(built-in and variable). Currently:
\begin{itemize}
\item
Upper and lower case for strings
\item
Convert to null-terminated C string
\end{itemize}
<<[[string_utils.f90]]>>=
<<File header>>
module string_utils
use, intrinsic :: iso_c_binding
<<Use kinds>>
<<Use strings>>
<<Standard module head>>
<<String utils: public>>
<<String utils: interfaces>>
contains
<<String utils: procedures>>
end module string_utils
@ %def string_utils
@
\subsection{Upper and Lower Case}
These are, unfortunately, not part of Fortran.
<<String utils: public>>=
public :: upper_case
public :: lower_case
<<String utils: interfaces>>=
interface upper_case
module procedure upper_case_char, upper_case_string
end interface
interface lower_case
module procedure lower_case_char, lower_case_string
end interface
<<String utils: procedures>>=
function upper_case_char (string) result (new_string)
character(*), intent(in) :: string
character(len(string)) :: new_string
integer :: pos, code
integer, parameter :: offset = ichar('A')-ichar('a')
do pos = 1, len (string)
code = ichar (string(pos:pos))
select case (code)
case (ichar('a'):ichar('z'))
new_string(pos:pos) = char (code + offset)
case default
new_string(pos:pos) = string(pos:pos)
end select
end do
end function upper_case_char
function lower_case_char (string) result (new_string)
character(*), intent(in) :: string
character(len(string)) :: new_string
integer :: pos, code
integer, parameter :: offset = ichar('a')-ichar('A')
do pos = 1, len (string)
code = ichar (string(pos:pos))
select case (code)
case (ichar('A'):ichar('Z'))
new_string(pos:pos) = char (code + offset)
case default
new_string(pos:pos) = string(pos:pos)
end select
end do
end function lower_case_char
function upper_case_string (string) result (new_string)
type(string_t), intent(in) :: string
type(string_t) :: new_string
new_string = upper_case_char (char (string))
end function upper_case_string
function lower_case_string (string) result (new_string)
type(string_t), intent(in) :: string
type(string_t) :: new_string
new_string = lower_case_char (char (string))
end function lower_case_string
@ %def upper_case lower_case
@
\subsection{C-compatible Output}
Convert a FORTRAN string into a zero terminated C string.
<<String utils: public>>=
public :: string_f2c
<<String utils: interfaces>>=
interface string_f2c
module procedure string_f2c_char, string_f2c_var_str
end interface string_f2c
<<String utils: procedures>>=
pure function string_f2c_char (i) result (o)
character(*), intent(in) :: i
character(kind=c_char, len=len (i) + 1) :: o
o = i // c_null_char
end function string_f2c_char
pure function string_f2c_var_str (i) result (o)
type(string_t), intent(in) :: i
character(kind=c_char, len=len (i) + 1) :: o
o = char (i) // c_null_char
end function string_f2c_var_str
@ %def string_f2c
@
\subsection{Number Conversion}
Create a string from a number. We use fixed format for the reals
and variable format for integers.
<<String utils: public>>=
public :: str
<<String utils: interfaces>>=
interface str
module procedure str_log, str_logs, str_int, str_ints, &
str_real, str_reals, str_complex, str_complexs
end interface
<<String utils: procedures>>=
function str_log (l) result (s)
logical, intent(in) :: l
type(string_t) :: s
if (l) then
s = "True"
else
s = "False"
end if
end function str_log
function str_logs (x) result (s)
logical, dimension(:), intent(in) :: x
<<concatenate strings>>
end function str_logs
function str_int (i) result (s)
integer, intent(in) :: i
type(string_t) :: s
character(32) :: buffer
write (buffer, "(I0)") i
s = var_str (trim (adjustl (buffer)))
end function str_int
function str_ints (x) result (s)
integer, dimension(:), intent(in) :: x
<<concatenate strings>>
end function str_ints
function str_real (x) result (s)
real(default), intent(in) :: x
type(string_t) :: s
character(32) :: buffer
write (buffer, "(ES17.10)") x
s = var_str (trim (adjustl (buffer)))
end function str_real
function str_reals (x) result (s)
real(default), dimension(:), intent(in) :: x
<<concatenate strings>>
end function str_reals
function str_complex (x) result (s)
complex(default), intent(in) :: x
type(string_t) :: s
s = str_real (real (x)) // " + i " // str_real (aimag (x))
end function str_complex
function str_complexs (x) result (s)
complex(default), dimension(:), intent(in) :: x
<<concatenate strings>>
end function str_complexs
@ %def str
<<concatenate strings>>=
type(string_t) :: s
integer :: i
s = '['
do i = 1, size(x) - 1
s = s // str(x(i)) // ', '
end do
s = s // str(x(size(x))) // ']'
@
@ Auxiliary: Read real, integer, string value.
<<String utils: public>>=
public :: read_rval
public :: read_ival
<<String utils: procedures>>=
function read_rval (s) result (rval)
real(default) :: rval
type(string_t), intent(in) :: s
character(80) :: buffer
buffer = s
read (buffer, *) rval
end function read_rval
function read_ival (s) result (ival)
integer :: ival
type(string_t), intent(in) :: s
character(80) :: buffer
buffer = s
read (buffer, *) ival
end function read_ival
@ %def read_rval read_ival
@
\subsection{String splitting}
<<String utils: public>>=
public :: string_contains_word
<<String utils: procedures>>=
pure function string_contains_word (str, word, include_identical) result (val)
logical :: val
type(string_t), intent(in) :: str, word
type(string_t) :: str_tmp, str_out
logical, intent(in), optional :: include_identical
logical :: yorn
str_tmp = str
val = .false.
yorn = .false.; if (present (include_identical)) yorn = include_identical
if (yorn) val = str == word
call split (str_tmp, str_out, word)
val = val .or. (str_out /= "")
end function string_contains_word
@ %def string_contains_word
@ Create an array of strings using a separator.
<<String utils: public>>=
public :: split_string
<<String utils: procedures>>=
pure subroutine split_string (str, separator, str_array)
type(string_t), dimension(:), allocatable, intent(out) :: str_array
type(string_t), intent(in) :: str, separator
type(string_t) :: str_tmp, str_out
integer :: n_str
n_str = 0; str_tmp = str
do while (string_contains_word (str_tmp, separator))
n_str = n_str + 1
call split (str_tmp, str_out, separator)
end do
allocate (str_array (n_str))
n_str = 1; str_tmp = str
do while (string_contains_word (str_tmp, separator))
call split (str_tmp, str_array (n_str), separator)
n_str = n_str + 1
end do
end subroutine split_string
@ %def split_string
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Format Utilities}
This module provides miscellaneous tools associated with formatting and
pretty-printing.
\begin{itemize}
\item
Horizontal separator lines in output
\item
Indenting an output line
\item
Formatting a number for \TeX\ output.
\item
Formatting a number for MetaPost output.
\item
Alternate numeric formats.
\end{itemize}
<<[[format_utils.f90]]>>=
<<File header>>
module format_utils
<<Use kinds>>
<<Use strings>>
use string_utils, only: lower_case
use io_units, only: given_output_unit
<<Standard module head>>
<<Format utils: public>>
contains
<<Format utils: procedures>>
end module format_utils
@ %def format_utils
@
\subsection{Line Output}
Write a separator line.
<<Format utils: public>>=
public :: write_separator
<<Format utils: procedures>>=
subroutine write_separator (u, mode)
integer, intent(in) :: u
integer, intent(in), optional :: mode
integer :: m
m = 1; if (present (mode)) m = mode
select case (m)
case default
write (u, "(A)") repeat ("-", 72)
case (1)
write (u, "(A)") repeat ("-", 72)
case (2)
write (u, "(A)") repeat ("=", 72)
end select
end subroutine write_separator
@ %def write_separator
@
Indent the line with given number of blanks.
<<Format utils: public>>=
public :: write_indent
<<Format utils: procedures>>=
subroutine write_indent (unit, indent)
integer, intent(in) :: unit
integer, intent(in), optional :: indent
if (present (indent)) then
write (unit, "(1x,A)", advance="no") repeat (" ", indent)
end if
end subroutine write_indent
@ %def write_indent
@
\subsection{Array Output}
Write an array of integers.
<<Format utils: public>>=
public :: write_integer_array
<<Format utils: procedures>>=
subroutine write_integer_array (array, unit, n_max, no_skip)
integer, intent(in), dimension(:) :: array
integer, intent(in), optional :: unit
integer, intent(in), optional :: n_max
logical, intent(in), optional :: no_skip
integer :: u, i, n
logical :: yorn
u = given_output_unit (unit)
yorn = .false.; if (present (no_skip)) yorn = no_skip
if (present (n_max)) then
n = n_max
else
n = size (array)
end if
do i = 1, n
if (i < n .or. yorn) then
write (u, "(I0, A)", advance = "no") array(i), ", "
else
write (u, "(I0)") array(i)
end if
end do
end subroutine write_integer_array
@ %def write_integer_array
@
\subsection{\TeX-compatible Output}
Quote underscore characters for use in \TeX\ output.
<<Format utils: public>>=
public :: quote_underscore
<<Format utils: procedures>>=
function quote_underscore (string) result (quoted)
type(string_t) :: quoted
type(string_t), intent(in) :: string
type(string_t) :: part
type(string_t) :: buffer
buffer = string
quoted = ""
do
call split (part, buffer, "_")
quoted = quoted // part
if (buffer == "") exit
quoted = quoted // "\_"
end do
end function quote_underscore
@ %def quote_underscore
@ Format a number with $n$ significant digits for use in \TeX\ documents.
<<Format utils: public>>=
public :: tex_format
<<Format utils: procedures>>=
function tex_format (rval, n_digits) result (string)
type(string_t) :: string
real(default), intent(in) :: rval
integer, intent(in) :: n_digits
integer :: e, n, w, d
real(default) :: absval
real(default) :: mantissa
character :: sign
character(20) :: format
character(80) :: cstr
n = min (abs (n_digits), 16)
if (rval == 0) then
string = "0"
else
absval = abs (rval)
e = int (log10 (absval))
if (rval < 0) then
sign = "-"
else
sign = ""
end if
select case (e)
case (:-3)
d = max (n - 1, 0)
w = max (d + 2, 2)
write (format, "('(F',I0,'.',I0,',A,I0,A)')") w, d
mantissa = absval * 10._default ** (1 - e)
write (cstr, fmt=format) mantissa, "\times 10^{", e - 1, "}"
case (-2:0)
d = max (n - e, 1 - e)
w = max (d + e + 2, d + 2)
write (format, "('(F',I0,'.',I0,')')") w, d
write (cstr, fmt=format) absval
case (1:2)
d = max (n - e - 1, -e, 0)
w = max (d + e + 2, d + 2, e + 2)
write (format, "('(F',I0,'.',I0,')')") w, d
write (cstr, fmt=format) absval
case default
d = max (n - 1, 0)
w = max (d + 2, 2)
write (format, "('(F',I0,'.',I0,',A,I0,A)')") w, d
mantissa = absval * 10._default ** (- e)
write (cstr, fmt=format) mantissa, "\times 10^{", e, "}"
end select
string = sign // trim (cstr)
end if
end function tex_format
@ %def tex_format
@
\subsection{Metapost-compatible Output}
Write a number for use in Metapost code:
<<Format utils: public>>=
public :: mp_format
<<Format utils: procedures>>=
function mp_format (rval) result (string)
type(string_t) :: string
real(default), intent(in) :: rval
character(16) :: tmp
write (tmp, "(G16.8)") rval
string = lower_case (trim (adjustl (trim (tmp))))
end function mp_format
@ %def mp_format
@
\subsection{Conditional Formatting}
Conditional format string, intended for switchable numeric precision.
<<Format utils: public>>=
public :: pac_fmt
<<Format utils: procedures>>=
subroutine pac_fmt (fmt, fmt_orig, fmt_pac, pacify)
character(*), intent(in) :: fmt_orig, fmt_pac
character(*), intent(out) :: fmt
logical, intent(in), optional :: pacify
logical :: pacified
pacified = .false.
if (present (pacify)) pacified = pacify
if (pacified) then
fmt = fmt_pac
else
fmt = fmt_orig
end if
end subroutine pac_fmt
@ %def pac_fmt
@
\subsection{Compressed output of integer arrays}
<<Format utils: public>>=
public :: write_compressed_integer_array
<<Format utils: procedures>>=
subroutine write_compressed_integer_array (chars, array)
character(len=*), intent(out) :: chars
integer, intent(in), allocatable, dimension(:) :: array
logical, dimension(:), allocatable :: used
character(len=16) :: tmp
type(string_t) :: string
integer :: i, j, start_chain, end_chain
chars = '[none]'
string = ""
if (allocated (array)) then
if (size (array) > 0) then
allocate (used (size (array)))
used = .false.
do i = 1, size (array)
if (.not. used(i)) then
start_chain = array(i)
end_chain = array(i)
used(i) = .true.
EXTEND: do
do j = 1, size (array)
if (array(j) == end_chain + 1) then
end_chain = array(j)
used(j) = .true.
cycle EXTEND
end if
if (array(j) == start_chain - 1) then
start_chain = array(j)
used(j) = .true.
cycle EXTEND
end if
end do
exit
end do EXTEND
if (end_chain - start_chain > 0) then
write (tmp, "(I0,A,I0)") start_chain, "-", end_chain
else
write (tmp, "(I0)") start_chain
end if
string = string // trim (tmp)
if (any (.not. used)) then
string = string // ','
end if
end if
end do
chars = string
end if
end if
chars = adjustr (chars)
end subroutine write_compressed_integer_array
@ %def write_compressed_integer_array
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Format Definitions}
This module provides named integer parameters that specify certain
format strings, used for numerical output.
<<[[format_defs.f90]]>>=
<<File header>>
module format_defs
<<Standard module head>>
<<Format defs: public parameters>>
end module format_defs
@ %def format_defs
@ We collect format strings for various numerical output formats here.
<<Format defs: public parameters>>=
character(*), parameter, public :: FMT_19 = "ES19.12"
character(*), parameter, public :: FMT_18 = "ES18.11"
character(*), parameter, public :: FMT_17 = "ES17.10"
character(*), parameter, public :: FMT_16 = "ES16.9"
character(*), parameter, public :: FMT_15 = "ES15.8"
character(*), parameter, public :: FMT_14 = "ES14.7"
character(*), parameter, public :: FMT_13 = "ES13.6"
character(*), parameter, public :: FMT_12 = "ES12.5"
character(*), parameter, public :: FMT_11 = "ES11.4"
character(*), parameter, public :: FMT_10 = "ES10.3"
@ %def FMT_10 FMT_11 FMT_12 FMT_13 FMT_14
@ %def FMT_15 FMT_16 FMT_17 FMT_18 FMT_19
@ Fixed-point formats for better readability, where appropriate.
<<Format defs: public parameters>>=
character(*), parameter, public :: FMF_12 = "F12.9"
@ %def FMF_12
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Numeric Utilities}
<<[[numeric_utils.f90]]>>=
<<File header>>
module numeric_utils
<<Use kinds>>
<<Use strings>>
use string_utils
use constants
use format_defs
<<Standard module head>>
<<Numeric utils: public>>
<<Numeric utils: parameters>>
<<Numeric utils: types>>
<<Numeric utils: interfaces>>
contains
<<Numeric utils: procedures>>
end module numeric_utils
@ %def numeric_utils
@
<<Numeric utils: public>>=
public :: assert
<<Numeric utils: procedures>>=
subroutine assert (unit, ok, description, exit_on_fail)
integer, intent(in) :: unit
logical, intent(in) :: ok
character(*), intent(in), optional :: description
logical, intent(in), optional :: exit_on_fail
logical :: ef
ef = .false.; if (present (exit_on_fail)) ef = exit_on_fail
if (.not. ok) then
if (present(description)) then
write (unit, "(A)") "* FAIL: " // description
else
write (unit, "(A)") "* FAIL: Assertion error"
end if
if (ef) stop 1
end if
end subroutine assert
@ %def assert
@ Compare numbers and output error message if not equal.
<<Numeric utils: public>>=
public:: assert_equal
interface assert_equal
module procedure assert_equal_integer, assert_equal_integers, &
assert_equal_real, assert_equal_reals, &
assert_equal_complex, assert_equal_complexs
end interface
@
<<Numeric utils: procedures>>=
subroutine assert_equal_integer (unit, lhs, rhs, description, exit_on_fail)
integer, intent(in) :: unit
integer, intent(in) :: lhs, rhs
character(*), intent(in), optional :: description
logical, intent(in), optional :: exit_on_fail
type(string_t) :: desc
logical :: ok
ok = lhs == rhs
desc = ''; if (present (description)) desc = var_str(description) // ": "
call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail)
end subroutine assert_equal_integer
@ %def assert_equal_integer
@
<<Numeric utils: procedures>>=
subroutine assert_equal_integers (unit, lhs, rhs, description, exit_on_fail)
integer, intent(in) :: unit
integer, dimension(:), intent(in) :: lhs, rhs
character(*), intent(in), optional :: description
logical, intent(in), optional :: exit_on_fail
type(string_t) :: desc
logical :: ok
ok = all(lhs == rhs)
desc = ''; if (present (description)) desc = var_str(description) // ": "
call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail)
end subroutine assert_equal_integers
@ %def assert_equal_integers
@
<<Numeric utils: procedures>>=
subroutine assert_equal_real (unit, lhs, rhs, description, &
abs_smallness, rel_smallness, exit_on_fail)
integer, intent(in) :: unit
real(default), intent(in) :: lhs, rhs
character(*), intent(in), optional :: description
real(default), intent(in), optional :: abs_smallness, rel_smallness
logical, intent(in), optional :: exit_on_fail
type(string_t) :: desc
logical :: ok
ok = nearly_equal (lhs, rhs, abs_smallness, rel_smallness)
desc = ''; if (present (description)) desc = var_str(description) // ": "
call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail)
end subroutine assert_equal_real
@ %def assert_equal_real
@
<<Numeric utils: procedures>>=
subroutine assert_equal_reals (unit, lhs, rhs, description, &
abs_smallness, rel_smallness, exit_on_fail)
integer, intent(in) :: unit
real(default), dimension(:), intent(in) :: lhs, rhs
character(*), intent(in), optional :: description
real(default), intent(in), optional :: abs_smallness, rel_smallness
logical, intent(in), optional :: exit_on_fail
type(string_t) :: desc
logical :: ok
ok = all(nearly_equal (lhs, rhs, abs_smallness, rel_smallness))
desc = ''; if (present (description)) desc = var_str(description) // ": "
call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail)
end subroutine assert_equal_reals
@ %def assert_equal_reals
@
<<Numeric utils: procedures>>=
subroutine assert_equal_complex (unit, lhs, rhs, description, &
abs_smallness, rel_smallness, exit_on_fail)
integer, intent(in) :: unit
complex(default), intent(in) :: lhs, rhs
character(*), intent(in), optional :: description
real(default), intent(in), optional :: abs_smallness, rel_smallness
logical, intent(in), optional :: exit_on_fail
type(string_t) :: desc
logical :: ok
ok = nearly_equal (real(lhs), real(rhs), abs_smallness, rel_smallness) &
.and. nearly_equal (aimag(lhs), aimag(rhs), abs_smallness, rel_smallness)
desc = ''; if (present (description)) desc = var_str(description) // ": "
call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail)
end subroutine assert_equal_complex
@ %def assert_equal_complex
@
<<Numeric utils: procedures>>=
subroutine assert_equal_complexs (unit, lhs, rhs, description, &
abs_smallness, rel_smallness, exit_on_fail)
integer, intent(in) :: unit
complex(default), dimension(:), intent(in) :: lhs, rhs
character(*), intent(in), optional :: description
real(default), intent(in), optional :: abs_smallness, rel_smallness
logical, intent(in), optional :: exit_on_fail
type(string_t) :: desc
logical :: ok
ok = all (nearly_equal (real(lhs), real(rhs), abs_smallness, rel_smallness)) &
.and. all (nearly_equal (aimag(lhs), aimag(rhs), abs_smallness, rel_smallness))
desc = ''; if (present (description)) desc = var_str(description) // ": "
call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail)
end subroutine assert_equal_complexs
@ %def assert_equal_complexs
@ Note that this poor man's check will be disabled if someone compiles
with [[-ffast-math]] or similar optimizations.
<<Numeric utils: procedures>>=
elemental function ieee_is_nan (x) result (yorn)
logical :: yorn
real(default), intent(in) :: x
yorn = (x /= x)
end function ieee_is_nan
@ %def ieee_is_nan
@ This is still not perfect but should work in most cases. Usually one
wants to compare to a relative epsilon [[rel_smallness]], except for
numbers close to zero defined by [[abs_smallness]]. Both might need
adaption to specific use cases but have reasonable defaults.
<<Numeric utils: public>>=
public :: nearly_equal
<<Numeric utils: interfaces>>=
interface nearly_equal
module procedure nearly_equal_real
module procedure nearly_equal_complex
end interface nearly_equal
<<Numeric utils: procedures>>=
elemental function nearly_equal_real (a, b, abs_smallness, rel_smallness) result (r)
logical :: r
real(default), intent(in) :: a, b
real(default), intent(in), optional :: abs_smallness, rel_smallness
real(default) :: abs_a, abs_b, diff, abs_small, rel_small
abs_a = abs (a)
abs_b = abs (b)
diff = abs (a - b)
! shortcut, handles infinities and nans
if (a == b) then
r = .true.
return
else if (ieee_is_nan (a) .or. ieee_is_nan (b) .or. ieee_is_nan (diff)) then
r = .false.
return
end if
abs_small = tiny_13; if (present (abs_smallness)) abs_small = abs_smallness
rel_small = tiny_10; if (present (rel_smallness)) rel_small = rel_smallness
if (abs_a < abs_small .and. abs_b < abs_small) then
r = diff < abs_small
else
r = diff / max (abs_a, abs_b) < rel_small
end if
end function nearly_equal_real
@ %def nearly_equal_real
<<Numeric utils: procedures>>=
elemental function nearly_equal_complex (a, b, abs_smallness, rel_smallness) result (r)
logical :: r
complex(default), intent(in) :: a, b
real(default), intent(in), optional :: abs_smallness, rel_smallness
r = nearly_equal_real (real (a), real (b), abs_smallness, rel_smallness) .and. &
nearly_equal_real (aimag (a), aimag(b), abs_smallness, rel_smallness)
end function nearly_equal_complex
@ %def neary_equal_complex
@ Often we will need to check whether floats vanish:
<<Numeric utils: public>>=
public:: vanishes
interface vanishes
module procedure vanishes_real, vanishes_complex
end interface
@
<<Numeric utils: procedures>>=
elemental function vanishes_real (x, abs_smallness, rel_smallness) result (r)
logical :: r
real(default), intent(in) :: x
real(default), intent(in), optional :: abs_smallness, rel_smallness
r = nearly_equal (x, zero, abs_smallness, rel_smallness)
end function vanishes_real
elemental function vanishes_complex (x, abs_smallness, rel_smallness) result (r)
logical :: r
complex(default), intent(in) :: x
real(default), intent(in), optional :: abs_smallness, rel_smallness
r = vanishes_real (abs (x), abs_smallness, rel_smallness)
end function vanishes_complex
@ %def vanishes
@
<<Numeric utils: public>>=
public :: expanded_amp2
<<Numeric utils: procedures>>=
pure function expanded_amp2 (amp_tree, amp_blob) result (amp2)
real(default) :: amp2
complex(default), dimension(:), intent(in) :: amp_tree, amp_blob
amp2 = sum (amp_tree * conjg (amp_tree) + &
amp_tree * conjg (amp_blob) + &
amp_blob * conjg (amp_tree))
end function expanded_amp2
@ %def expanded_amp2
@
<<Numeric utils: public>>=
public :: abs2
<<Numeric utils: procedures>>=
elemental function abs2 (c) result (c2)
real(default) :: c2
complex(default), intent(in) :: c
c2 = real (c * conjg(c))
end function abs2
@ %def abs2
-@ Remove all duplicates from a list of integers.
+@ Remove all duplicates from an array of signed integers and returns an
+unordered array of remaining elements.
This method does not really fit into this module. It could be part of a
-larger module which deals with list manipulations.
+larger module which deals with array manipulations.
<<Numeric utils: public>>=
- public :: remove_duplicates_from_list
+ public :: remove_duplicates_from_int_array
<<Numeric utils: procedures>>=
- function remove_duplicates_from_list (list) result (list_clean)
- integer, dimension(:), allocatable :: list_clean
- integer, intent(in), dimension(:) :: list
- integer, parameter :: N_MAX = 20
- integer, dimension(N_MAX) :: buf
- integer :: i_buf, i_list, n_buf
- buf = -1; i_buf = 1
- if (size (list) > N_MAX) return
- do i_list = 1, size (list)
- if (.not. any (list(i_list) == buf)) then
- buf(i_buf) = list(i_list)
- i_buf = i_buf + 1
- end if
+ function remove_duplicates_from_int_array (array) result (array_unique)
+ integer, intent(in), dimension(:) :: array
+ integer, dimension(:), allocatable :: array_unique
+ integer :: i
+ allocate (array_unique(1))
+ array_unique(1) = array(1)
+ do i = 2, size (array)
+ if (any (array_unique == array(i))) cycle
+ array_unique = [array_unique, [array(i)]]
end do
- n_buf = count (buf >= 0)
- allocate (list_clean (n_buf))
- list_clean = buf (1 : n_buf)
- end function remove_duplicates_from_list
+ end function remove_duplicates_from_int_array
-@ %def remove_duplicates_from_list
+@ %def remove_duplicates_from_int_array
@
<<Numeric utils: public>>=
public :: extend_integer_array
<<Numeric utils: procedures>>=
subroutine extend_integer_array (list, incr, initial_value)
integer, intent(inout), dimension(:), allocatable :: list
integer, intent(in) :: incr
integer, intent(in), optional :: initial_value
integer, dimension(:), allocatable :: list_store
integer :: n, ini
ini = 0; if (present (initial_value)) ini = initial_value
n = size (list)
allocate (list_store (n))
list_store = list
deallocate (list)
allocate (list (n+incr))
list(1:n) = list_store
list(1+n : n+incr) = ini
deallocate (list_store)
end subroutine extend_integer_array
@ %def extend_integer_array
@
<<Numeric utils: public>>=
public :: crop_integer_array
<<Numeric utils: procedures>>=
subroutine crop_integer_array (list, i_crop)
integer, intent(inout), dimension(:), allocatable :: list
integer, intent(in) :: i_crop
integer, dimension(:), allocatable :: list_store
allocate (list_store (i_crop))
list_store = list(1:i_crop)
deallocate (list)
allocate (list (i_crop))
list = list_store
deallocate (list_store)
end subroutine crop_integer_array
@ %def crop_integer_array
@ We also need an evaluation of $\log x$ which is stable near $x=1$.
<<Numeric utils: public>>=
public :: log_prec
<<Numeric utils: procedures>>=
function log_prec (x, xb) result (lx)
real(default), intent(in) :: x, xb
real(default) :: a1, a2, a3, lx
a1 = xb
a2 = a1 * xb / two
a3 = a2 * xb * two / three
if (abs (a3) < epsilon (a3)) then
lx = - a1 - a2 - a3
else
lx = log (x)
end if
end function log_prec
@ %def log_prec
@
<<Numeric utils: public>>=
public :: split_array
<<Numeric utils: interfaces>>=
interface split_array
module procedure split_integer_array
module procedure split_real_array
end interface
<<Numeric utils: procedures>>=
subroutine split_integer_array (list1, list2)
integer, intent(inout), dimension(:), allocatable :: list1, list2
integer, dimension(:), allocatable :: list_store
allocate (list_store (size (list1) - size (list2)))
list2 = list1(:size (list2))
list_store = list1 (size (list2) + 1:)
deallocate (list1)
allocate (list1 (size (list_store)))
list1 = list_store
deallocate (list_store)
end subroutine split_integer_array
subroutine split_real_array (list1, list2)
real(default), intent(inout), dimension(:), allocatable :: list1, list2
real(default), dimension(:), allocatable :: list_store
allocate (list_store (size (list1) - size (list2)))
list2 = list1(:size (list2))
list_store = list1 (size (list2) + 1:)
deallocate (list1)
allocate (list1 (size (list_store)))
list1 = list_store
deallocate (list_store)
end subroutine split_real_array
@ %def split_array
@

File Metadata

Mime Type
text/x-diff
Expires
Sat, Dec 21, 6:00 PM (9 h, 48 m)
Storage Engine
local-disk
Storage Format
Raw Data
Storage Handle
d8/64/ac534fb97b4ac12421095dfc1d6e
Default Alt Text
(1 MB)

Event Timeline