Index: trunk/ChangeLog =================================================================== --- trunk/ChangeLog (revision 8456) +++ trunk/ChangeLog (revision 8457) @@ -1,2132 +1,2135 @@ ChangeLog -- Summary of changes to the WHIZARD package Use svn log to see detailed changes. Version 3.0.0_beta+ +2020-09-26 + Support for negative PDG particles from certain UFO models + 2020-09-24 Allow for QNUMBERS blocks in BSM SLHA files 2020-09-22 Full support for compilation with clang(++) on Darwin/macOS More documentation in the manual Minor clean-ups 2020-09-16 Bug fix enables reading LCIO events with LCIO v2.15+ ################################################################## 2020-09-16 RELEASE: version 2.8.5 2020-09-11 Bug fix for H->tau tau transverse polarization with PYTHIA6 (thanks to Junping Tian / Akiya Miyamoto) 2020-09-09 Fix a long standing bug (since 2.0) in the calculation of color factors when particles of different color were combined in a particle class. NB: O'Mega never produced a wrong number, it only declared all processes as invalid. 2020-09-08 Enable Openloops matrix element equivalences for optimization 2020-09-02 Compatibility fix for PYTHIA v8.301+ interface 2020-09-01 Support exclusive jet clustering in ee for Fastjet interface ################################################################## 2020-08-30 RELEASE: version 3.0.0_beta 2020-08-27 Major revision of NLO distributions and events for processes with structure functions: - Use parton momenta/flavors (instead of beams) for events - Bug fix for Lorentz boosts and Lorentz frames of momenta - Bug fix: apply cuts to virtual NLO component in correct frame - Correctly assign ISR radiation momenta in data structures - Refactoring on quantum numbers for NLO event data structures - Functional tests for hadron collider NLO distributions - many minor bug fixes regarding NLO hadron collider physics 2020-08-11 Bug fix for linking problem with OpenMPI 2020-08-07 New WHIZARD API: WHIZARD can be externally linked as a library, added examples for Fortran, C, C++ programs ################################################################## 2020-07-08 RELEASE: version 2.8.4 2020-07-07 Bug fix: steering of UFO Majorana models from WHIZARD ################################################################## 2020-07-06 Combined integration also for hadron collider processes at NLO 2020-07-05 Bug fix: correctly steer e+e- FastJet clustering algorithms Major revision of NLO differential distributions and events: - Correctly assign quantum numbers to NLO fixed-order events - Correctly assign weights to NLO fixed-order events for combined simulation - Cut all NLO fixed-order subevents in event groups individually - Only allow "sigma" normalization for NLO fixed-order events - Use correct PDF setup for NLO counter events - Several technical fixes and updates of the NLO testsuite ################################################################## 2020-07-03 RELEASE: version 2.8.3 2020-07-02 Feature-complete UFO implementation for Majorana fermions 2020-06-22 Running width scheme supported for O'Mega matrix elements 2020-06-20 Adding H-s-s coupling to SM_Higgs(_CKM) models 2020-06-17 Completion of ILC 2->6 fermion extended test suite 2020-06-15 Bug fix: PYTHIA6/Tauola, correctly assign tau spins for stau decays 2020-06-09 Bug fix: correctly update calls for additional VAMP/2 iterations Bug fix: correct assignment for tau spins from PYTHIA6 interface 2020-06-04 Bug fix: cascades2 tree merge with empty subtree(s) 2020-05-31 Switch $epa_mode for different EPA implementations 2020-05-26 Bug fix: spin information transferred for resonance histories 2020-04-13 HepMC: correct weighted events for non-xsec event normalizations 2020-04-04 Improved HepMC3 interface: HepMC3 Root/RootTree interface 2020-03-24 ISR: Fix on-shell kinematics for events with ?isr_handler=true (set ?isr_handler_keep_mass=false for old behavior) 2020-03-11 Beam masses are correctly passed to hard matrix element for CIRCE2 EPA with polarized beams: double-counting corrected ################################################################## 2020-03-03 RELEASE: version 3.0.0_alpha 2020-02-25 Bug fix: Scale and alphas can be retrieved from internal event format to external formats 2020-02-17 Bug fix: ?keep_failed_events now forces output of actual event data Bug fix: particle-set reconstruction (rescanning events w/o radiation) 2020-01-28 Bug fix for left-over EPA parameter epa_e_max (replaced by epa_q_max) 2020-01-23 Bug fix for real components of NLO QCD 2->1 processes 2020-01-22 Bug fix: correct random number sequencing during parallel MPI event generation with rng_stream 2020-01-21 Consistent distribution of events during parallel MPI event generation 2020-01-20 Bug fix for configure setup for automake v1.16+ 2020-01-18 General SLHA parameter files for UFO models supported 2020-01-08 Bug fix: correctly register RECOLA processes with flavor sums 2019-12-19 Support for UFO customized propagators O'Mega unit tests for fermion-number violating interactions 2019-12-10 For distribution building: check for graphviz/dot version 2.40 or newer 2019-11-21 Bug fix: alternate setups now work correctly Infrastructure for accessing alpha_QED event-by-event Guard against tiny numbers that break ASCII event output Enable inverse hyperbolic functions as SINDARIN observables Remove old compiler bug workarounds 2019-11-20 Allow quoted -e argument, implemented -f option 2019-11-19 Bug fix: resonance histories now work also with UFO models Fix in numerical precision of ASCII VAMP2 grids 2019-11-06 Add squared matrix elements to the LCIO event header 2019-11-05 Do not include RNG state in MD5 sum for CIRCE1/2 2019-11-04 Full CIRCE2 ILC 250 and 500 GeV beam spectra added Minor update on LCIO event header information 2019-10-30 NLO QCD for final states completed When using Openloops, v2.1.1+ mandatory 2019-10-25 Binary grid files for VAMP2 integrator ################################################################## 2019-10-24 RELEASE: version 2.8.2 2019-10-20 Bug fix for HepMC linker flags 2019-10-19 Support for spin-2 particles from UFO files 2019-09-27 LCIO event format allows rescan and alternate weights 2019-09-24 Compatibility fix for OCaml v4.08.0+ ################################################################## 2019-09-21 RELEASE: version 2.8.1 2019-09-19 Carriage return characters in UFO models can be parsed Mathematica symbols in UFO models possible Unused/undefined parameters in UFO models handled 2019-09-13 New extended NLO test suite for ee and pp processes 2019-09-09 Photon isolation (separation of perturbative and fragmentation part a la Frixione) 2019-09-05 Major progress on NLO QCD for hadron collisions: - correctly assign flavor structures for alpha regions - fix crossing of particles for initial state splittings - correct assignment for PDF factors for real subtractions - fix kinematics for collinear splittings - bug fix for integrated virtual subtraction terms 2019-09-03 b and c jet selection in cuts and analysis 2019-08-27 Support for Intel MPI 2019-08-20 Complete (preliminary) HepMC3 support (incl. backwards HepMC2 write/read mode) 2019-08-08 Bug fix: handle carriage returns in UFO files (non-Unix OS) ################################################################## 2019-08-07 RELEASE: version 2.8.0 2019-07-31 Complete WHIZARD UFO interface: - general Lorentz structures - matrix element support for general color factors - missing features: Majorana fermions and SLHA 2019-07-20 Make WHIZARD compatible with OCaml 4.08.0+ 2019-07-19 Fix version testing for LHAPDF 6.2.3 and newer Minimal required OCaml version is now 4.02.3. 2019-04-18 Correctly generate ordered FKS tuples for alpha regions from all possible underlying Born processes 2019-04-08 Extended O'Mega/Recola matrix element test suite 2019-03-29 Correct identical particle symmetry factors for FKS subtraction 2019-03-28 Correct assertion of spin-correlated matrix elements for hadron collisions 2019-03-27 Bug fix for cut-off parameter delta_i for collinear plus/minus regions ################################################################## 2019-03-27 RELEASE: version 2.7.1 2019-02-19 Further infrastructure for HepMC3 interface (v3.01.00) 2019-02-07 Explicit configure option for using debugging options Bug fix for performance by removing unnecessary debug operations 2019-01-29 Bug fix for DGLAP remnants with cut-off parameter delta_i 2019-01-24 Radiative decay neu2 -> neu1 A added to MSSM_Hgg model ################################################################## 2019-01-21 RELEASE: version 2.7.0 2018-12-18 Support RECOLA for integrated und unintegrated subtractions 2018-12-11 FCNC top-up sector in model SM_top_anom 2018-12-05 Use libtirpc instead of SunRPC on Arch Linux etc. 2018-11-30 Display rescaling factor for weighted event samples with cuts 2018-11-29 Reintroduce check against different masses in flavor sums Bug fix for wrong couplings in the Littlest Higgs model(s) 2018-11-22 Bug fix for rescanning events with beam structure 2018-11-09 Major refactoring of internal process data 2018-11-02 PYTHIA8 interface 2018-10-29 Flat phase space parametrization with RAMBO (on diet) implemented 2018-10-17 Revise extended test suite 2018-09-27 Process container for RECOLA processes 2018-09-15 Fixes by M. Berggren for PYTHIA6 interface 2018-09-14 First fixes after HepForge modernization ################################################################## 2018-08-23 RELEASE: version 2.6.4 2018-08-09 Infrastructure to check colored subevents 2018-07-10 Infrastructure for running WHIZARD in batch mode 2018-07-04 MPI available from distribution tarball 2018-06-03 Support Intel Fortran Compiler under MAC OS X 2018-05-07 FKS slicing parameter delta_i (initial state) implementend 2018-05-03 Refactor structure function assignment for NLO 2018-05-02 FKS slicing parameter xi_cut, delta_0 implemented 2018-04-20 Workspace subdirectory for process integration (grid/phs files) Packing/unpacking of files at job end/start Exporting integration results from scan loops 2018-04-13 Extended QCD NLO test suite 2018-04-09 Bug fix for Higgs Singlet Extension model 2018-04-06 Workspace subdirectory for process generation and compilation --job-id option for creating job-specific names 2018-03-20 Bug fix for color flow matching in hadron collisions with identical initial state quarks 2018-03-08 Structure functions quantum numbers correctly assigned for NLO 2018-02-24 Configure setup includes 'pgfortran' and 'flang' 2018-02-21 Include spin-correlated matrix elements in interactions 2018-02-15 Separate module for QED ISR structure functions ################################################################## 2018-02-10 RELEASE: version 2.6.3 2018-02-08 Improvements in memory management for PS generation 2018-01-31 Partial refactoring: quantum number assigment NLO Initial-state QCD splittings for hadron collisions 2018-01-25 Bug fix for weighted events with VAMP2 2018-01-17 Generalized interface for Recola versions 1.3+ and 2.1+ 2018-01-15 Channel equivalences also for VAMP2 integrator 2018-01-12 Fix for OCaml compiler 4.06 (and newer) 2017-12-19 RECOLA matrix elements with flavor sums can be integrated 2017-12-18 Bug fix for segmentation fault in empty resonance histories 2017-12-16 Fixing a bug in PYTHIA6 PYHEPC routine by omitting CMShowers from transferral between PYTHIA and WHIZARD event records 2017-12-15 Event index for multiple processes in event file correct ################################################################## 2017-12-13 RELEASE: version 2.6.2 2017-12-07 User can set offset in event numbers 2017-11-29 Possibility to have more than one RECOLA process in one file 2017-11-23 Transversal/mixed (and unitarized) dim-8 operators 2017-11-16 epa_q_max replaces epa_e_max (trivial factor 2) 2017-11-15 O'Mega matrix element compilation silent now 2017-11-14 Complete expanded P-wave form factor for top threshold 2017-11-10 Incoming particles can be accessed in SINDARIN 2017-11-08 Improved handling of resonance insertion, additional parameters 2017-11-04 Added Higgs-electron coupling (SM_Higgs) ################################################################## 2017-11-03 RELEASE: version 2.6.1 2017-10-20 More than 5 NLO components possible at same time 2017-10-19 Gaussian cutoff for shower resonance matching 2017-10-12 Alternative (more efficient) method to generate phase space file 2017-10-11 Bug fix for shower resonance histories for processes with multiple components 2017-09-25 Bug fix for process libraries in shower resonance histories 2017-09-21 Correctly generate pT distribution for EPA remnants 2017-09-20 Set branching ratios for unstable particles also by hand 2017-09-14 Correctly generate pT distribution for ISR photons ################################################################## 2017-09-08 RELEASE: version 2.6.0 2017-09-05 Bug fix for initial state NLO QCD flavor structures Real and virtual NLO QCD hadron collider processes work with internal interactions 2017-09-04 Fully validated MPI integration and event generation 2017-09-01 Resonance histories for shower: full support Bug fix in O'Mega model constraints O'Mega allows to output a parsable form of the DAG 2017-08-24 Resonance histories in events for transferral to parton shower (e.g. in ee -> jjjj) 2017-08-01 Alpha version of HepMC v3 interface (not yet really functional) 2017-07-31 Beta version for RECOLA OLP support 2017-07-06 Radiation generator fix for LHC processes 2017-06-30 Fix bug for NLO with structure functions and/or polarization 2017-06-23 Collinear limit for QED corrections works 2017-06-17 POWHEG grids generated already during integration 2017-06-12 Soft limit for QED corrections works 2017-05-16 Beta version of full MPI parallelization (VAMP2) Check consistency of POWHEG grid files Logfile config-summary.log for configure summary 2017-05-12 Allow polarization in top threshold 2017-05-09 Minimal demand automake 1.12.2 Silent rules for make procedures 2017-05-07 Major fix for POWHEG damping Correctly initialize FKS ISR phasespace ################################################################## 2017-05-06 RELEASE: version 2.5.0 2017-05-05 Full UFO support (SM-like models) Fixed-beam ISR FKS phase space 2017-04-26 QED splittings in radiation generator 2017-04-10 Retire deprecated O'Mega vertex cache files ################################################################## 2017-03-24 RELEASE: version 2.4.1 2017-03-16 Distinguish resonance charge in phase space channels Keep track of resonance histories in phase space Complex mass scheme default for OpenLoops amplitudes 2017-03-13 Fix helicities for polarized OpenLoops calculations 2017-03-09 Possibility to advance RNG state in rng_stream 2017-03-04 General setup for partitioning real emission phase space 2017-03-06 Bug fix on rescan command for converting event files 2017-02-27 Alternative multi-channel VEGAS implementation VAMP2: serial backbone for MPI setup Smoothstep top threshold matching 2017-02-25 Single-beam structure function with s-channel mapping supported Safeguard against invalid process libraries 2017-02-16 Radiation generator for photon emission 2017-02-10 Fixes for NLO QCD processes (color correlations) 2017-01-16 LCIO variable takes precedence over LCIO_DIR 2017-01-13 Alternative random number generator rng_stream (cf. L'Ecuyer et al.) 2017-01-01 Fix for multi-flavor BLHA tree matrix elements 2016-12-31 Grid path option for VAMP grids 2016-12-28 Alpha version of Recola OLP support 2016-12-27 Dalitz plots for FKS phase space 2016-12-14 NLO multi-flavor events possible 2016-12-09 LCIO event header information added 2016-12-02 Alpha version of RECOLA interface Bug fix for generator status in LCIO ################################################################## 2016-11-28 RELEASE: version 2.4.0 2016-11-24 Bug fix for OpenLoops interface: EW scheme is set by WHIZARD Bug fixes for top threshold implementation 2016-11-11 Refactoring of dispatching 2016-10-18 Bug fix for LCIO output 2016-10-10 First implementation for collinear soft terms 2016-10-06 First full WHIZARD models from UFO files 2016-10-05 WHIZARD does not support legacy gcc 4.7.4 any longer 2016-09-30 Major refactoring of process core and NLO components 2016-09-23 WHIZARD homogeneous entity: discarding subconfigures for CIRCE1/2, O'Mega, VAMP subpackages; these are reconstructable by script projectors 2016-09-06 Introduce main configure summary 2016-08-26 Fix memory leak in event generation ################################################################## 2016-08-25 RELEASE: version 2.3.1 2016-08-19 Bug fix for EW-scheme dependence of gluino propagators 2016-08-01 Beta version of complex mass scheme support 2016-07-26 Fix bug in POWHEG damping for the matching ################################################################## 2016-07-21 RELEASE: version 2.3.0 2016-07-20 UFO file support (alpha version) in O'Mega 2016-07-13 New (more) stable of WHIZARD GUI Support for EW schemes for OpenLoops Factorized NLO top decays for threshold model 2016-06-15 Passing factorization scale to PYTHIA6 Adding charge and neutral observables 2016-06-14 Correcting angular distribution/tweaked kinematics in non-collinear structure functions splittings 2016-05-10 Include (Fortran) TAUOLA/PHOTOS for tau decays via PYTHIA6 (backwards validation of LC CDR/TDR samples) 2016-04-27 Within OpenLoops virtuals: support for Collier library 2016-04-25 O'Mega vertex tables only loaded at first usage 2016-04-21 New CJ15 PDF parameterizations added 2016-04-21 Support for hadron collisions at NLO QCD 2016-04-05 Support for different (parameter) schemes in model files 2016-03-31 Correct transferral of lifetime/vertex from PYTHIA/TAUOLA into the event record 2016-03-21 New internal implementation of polarization via Bloch vectors, remove pointer constructions 2016-03-13 Extension of cascade syntax for processes: exclude propagators/vertices etc. possible 2016-02-24 Full support for OpenLoops QCD NLO matrix elements, inclusion in test suite 2016-02-12 Substantial progress on QCD NLO support 2016-02-02 Automated resonance mapping for FKS subtraction 2015-12-17 New BSM model WZW for diphoton resonances ################################################################## 2015-11-22 RELEASE: version 2.2.8 2015-11-21 Bug fix for fixed-order NLO events 2015-11-20 Anomalous FCNC top-charm vertices 2015-11-19 StdHEP output via HEPEVT/HEPEV4 supported 2015-11-18 Full set of electroweak dim-6 operators included 2015-10-22 Polarized one-loop amplitudes supported 2015-10-21 Fixes for event formats for showered events 2015-10-14 Callback mechanism for event output 2015-09-22 Bypass matrix elements in pure event sample rescans StdHep frozen final version v5.06.01 included internally 2015-09-21 configure option --with-precision to demand 64bit, 80bit, or 128bit Fortran and bind C precision types 2015-09-07 More extensive tests of NLO infrastructure and POWHEG matching 2015-09-01 NLO decay infrastructure User-defined squared matrix elements Inclusive FastJet algorithm plugin Numerical improvement for small boosts ################################################################## 2015-08-11 RELEASE: version 2.2.7 2015-08-10 Infrastructure for damped POWHEG Massive emitters in POWHEG Born matrix elements via BLHA GoSam filters via SINDARIN Minor running coupling bug fixes Fixed-order NLO events 2015-08-06 CT14 PDFs included (LO, NLO, NNLL) 2015-07-07 Revalidation of ILC WHIZARD-PYTHIA event chain Extended test suite for showered events Alpha version of massive FSR for POWHEG 2015-06-09 Fix memory leak in interaction for long cascades Catch mismatch between beam definition and CIRCE2 spectrum 2015-06-08 Automated POWHEG matching: beta version Infrastructure for GKS matching Alpha version of fixed-order NLO events CIRCE2 polarization averaged spectra with explicitly polarized beams 2015-05-12 Abstract matching type: OO structure for matching/merging 2015-05-07 Bug fix in event record WHIZARD-PYTHIA6 transferral Gaussian beam spectra for lepton colliders ################################################################## 2015-05-02 RELEASE: version 2.2.6 2015-05-01 Models for (unitarized) tensor resonances in VBS 2015-04-28 Bug fix in channel weights for event generation. 2015-04-18 Improved event record transfer WHIZARD/PYTHIA6 2015-03-19 POWHEG matching: alpha version ################################################################## 2015-02-27 RELEASE: version 2.2.5 2015-02-26 Abstract types for quantum numbers 2015-02-25 Read-in of StdHEP events, self-tests 2015-02-22 Bug fix for mother-daughter relations in showered/hadronized events 2015-02-20 Projection on polarization in intermediate states 2015-02-13 Correct treatment of beam remnants in event formats (also LC remnants) ################################################################## 2015-02-06 RELEASE: version 2.2.4 2015-02-06 Bug fix in event output 2015-02-05 LCIO event format supported 2015-01-30 Including state matrices in WHIZARD's internal IO Versioning for WHIZARD's internal IO Libtool update from 2.4.3 to 2.4.5 LCIO event output (beta version) 2015-01-27 Progress on NLO integration Fixing a bug for multiple processes in a single event file when using beam event files 2015-01-19 Bug fix for spin correlations evaluated in the rest frame of the mother particle 2015-01-17 Regression fix for statically linked processes from SARAH and FeynRules 2015-01-10 NLO: massive FKS emitters supported (experimental) 2015-01-06 MMHT2014 PDF sets included 2015-01-05 Handling mass degeneracies in auto_decays 2014-12-19 Fixing bug in rescan of event files ################################################################## 2014-11-30 RELEASE: version 2.2.3 2014-11-29 Beta version of LO continuum/NLL-threshold matched top threshold model for e+e- physics 2014-11-28 More internal refactoring: disentanglement of module dependencies 2014-11-21 OVM: O'Mega Virtual Machine, bytecode instructions instead of compiled Fortran code 2014-11-01 Higgs Singlet extension model included 2014-10-18 Internal restructuring of code; half-way WHIZARD main code file disassembled 2014-07-09 Alpha version of NLO infrastructure ################################################################## 2014-07-06 RELEASE: version 2.2.2 2014-07-05 CIRCE2: correlated LC beam spectra and GuineaPig Interface to LC machine parameters 2014-07-01 Reading LHEF for decayed/factorized/showered/ hadronized events 2014-06-25 Configure support for GoSAM/Ninja/Form/QGraf 2014-06-22 LHAPDF6 interface 2014-06-18 Module for automatic generation of radiation and loop infrastructure code 2014-06-11 Improved internal directory structure ################################################################## 2014-06-03 RELEASE: version 2.2.1 2014-05-30 Extensions of internal PDG arrays 2014-05-26 FastJet interface 2014-05-24 CJ12 PDFs included 2014-05-20 Regression fix for external models (via SARAH or FeynRules) ################################################################## 2014-05-18 RELEASE: version 2.2.0 2014-04-11 Multiple components: inclusive process definitions, syntax: process A + B + ... 2014-03-13 Improved PS mappings for e+e- ISR ILC TDR and CLIC spectra included in CIRCE1 2014-02-23 New models: AltH w\ Higgs for exclusion purposes, SM_rx for Dim 6-/Dim-8 operators, SSC for general strong interactions (w/ Higgs), and NoH_rx (w\ Higgs) 2014-02-14 Improved s-channel mapping, new on-shell production mapping (e.g. Drell-Yan) 2014-02-03 PRE-RELEASE: version 2.2.0_beta 2014-01-26 O'Mega: Feynman diagram generation possible (again) 2013-12-16 HOPPET interface for b parton matching 2013-11-15 PRE-RELEASE: version 2.2.0_alpha-4 2013-10-27 LHEF standards 1.0/2.0/3.0 implemented 2013-10-15 PRE-RELEASE: version 2.2.0_alpha-3 2013-10-02 PRE-RELEASE: version 2.2.0_alpha-2 2013-09-25 PRE-RELEASE: version 2.2.0_alpha-1 2013-09-12 PRE-RELEASE: version 2.2.0_alpha 2013-09-03 General 2HDM implemented 2013-08-18 Rescanning/recalculating events 2013-06-07 Reconstruction of complete event from 4-momenta possible 2013-05-06 Process library stacks 2013-05-02 Process stacks 2013-04-29 Single-particle phase space module 2013-04-26 Abstract interface for random number generator 2013-04-24 More object-orientation on modules Midpoint-rule integrator 2013-04-05 Object-oriented integration and event generation 2013-03-12 Processes recasted object-oriented: MEs, scales, structure functions First infrastructure for general Lorentz structures 2013-01-17 Object-orientated reworking of library and process core, more variable internal structure, unit tests 2012-12-14 Update Pythia version to 6.4.27 2012-12-04 Fix the phase in HAZ vertices 2012-11-21 First O'Mega unit tests, some infrastructure 2012-11-13 Bug fix in anom. HVV Lorentz structures ################################################################## 2012-09-18 RELEASE: version 2.1.1 2012-09-11 Model MSSM_Hgg with Hgg and HAA vertices 2012-09-10 First version of implementation of multiple interactions in WHIZARD 2012-09-05 Infrastructure for internal CKKW matching 2012-09-02 C, C++, Python API 2012-07-19 Fixing particle numbering in HepMC format ################################################################## 2012-06-15 RELEASE: version 2.1.0 2012-06-14 Analytical and kT-ordered shower officially released PYTHIA interface officially released 2012-05-09 Intrisince PDFs can be used for showering 2012-05-04 Anomalous Higgs couplings a la hep-ph/9902321 ################################################################## 2012-03-19 RELEASE: version 2.0.7 2012-03-15 Run IDs are available now More event variables in analysis Modified raw event format (compatibility mode exists) 2012-03-12 Bug fix in decay-integration order MLM matching steered completely internally now 2012-03-09 Special phase space mapping for narrow resonances decaying to 4-particle final states with far off-shell intermediate states Running alphas from PDF collaborations with builtin PDFs 2012-02-16 Bug fix in cascades decay infrastructure 2012-02-04 WHIZARD documentation compatible with TeXLive 2011 2012-02-01 Bug fix in FeynRules interface with --prefix flag 2012-01-29 Bug fix with name clash of O'Mega variable names 2012-01-27 Update internal PYTHIA to version 6.4.26 Bug fix in LHEF output 2012-01-21 Catching stricter automake 1.11.2 rules 2011-12-23 Bug fix in decay cascade setup 2011-12-20 Bug fix in helicity selection rules 2011-12-16 Accuracy goal reimplemented 2011-12-14 WHIZARD compatible with TeXLive 2011 2011-12-09 Option --user-target added ################################################################## 2011-12-07 RELEASE: version 2.0.6 2011-12-07 Bug fixes in SM_top_anom Added missing entries to HepMC format 2011-12-06 Allow to pass options to O'Mega Bug fix for HEPEVT block for showered/hadronized events 2011-12-01 Reenabled user plug-in for external code for cuts, structure functions, routines etc. 2011-11-29 Changed model SM_Higgs for Higgs phenomenology 2011-11-25 Supporting a Y, (B-L) Z' model 2011-11-23 Make WHIZARD compatible for MAC OS X Lion/XCode 4 2011-09-25 WHIZARD paper published: Eur.Phys.J. C71 (2011) 1742 2011-08-16 Model SM_QCD: QCD with one EW insertion 2011-07-19 Explicit output channel for dvips avoids printing 2011-07-10 Test suite for WHIZARD unit tests 2011-07-01 Commands for matrix element tests More OpenMP parallelization of kinematics Added unit tests 2011-06-23 Conversion of CIRCE2 from F77 to F90, major clean-up 2011-06-14 Conversion of CIRCE1 from F77 to F90 2011-06-10 OpenMP parallelization of channel kinematics (by Matthias Trudewind) 2011-05-31 RELEASE: version 1.97 2011-05-24 Minor bug fixes: update grids and elsif statement. ################################################################## 2011-05-10 RELEASE: version 2.0.5 2011-05-09 Fixed bug in final state flavor sums Minor improvements on phase-space setup 2011-05-05 Minor bug fixes 2011-04-15 WHIZARD as a precompiled 64-bit binary available 2011-04-06 Wall clock instead of cpu time for time estimates 2011-04-05 Major improvement on the phase space setup 2011-04-02 OpenMP parallelization for helicity loop in O'Mega matrix elements 2011-03-31 Tools for relocating WHIZARD and use in batch environments 2011-03-29 Completely static builds possible, profiling options 2011-03-28 Visualization of integration history 2011-03-27 Fixed broken K-matrix implementation 2011-03-23 Including the GAMELAN manual in the distribution 2011-01-26 WHIZARD analysis can handle hadronized event files 2011-01-17 MSTW2008 and CT10 PDF sets included 2010-12-23 Inclusion of NMSSM with Hgg couplings 2010-12-21 Advanced options for integration passes 2010-11-16 WHIZARD supports CTEQ6 and possibly other PDFs directly; data files included in the distribution ################################################################## 2010-10-26 RELEASE: version 2.0.4 2010-10-06 Bug fix in MSSM implementation 2010-10-01 Update to libtool 2.4 2010-09-29 Support for anomalous top couplings (form factors etc.) Bug fix for running gauge Yukawa SUSY couplings 2010-09-28 RELEASE: version 1.96 2010-09-21 Beam remnants and pT spectra for lepton collider re-enabled Restructuring subevt class 2010-09-16 Shower and matching are disabled by default PYTHIA as a conditional on these two options 2010-09-14 Possibility to read in beam spectra re-enabled (e.g. Guinea Pig) 2010-09-13 Energy scan as (pseudo-) structure functions re-implemented 2010-09-10 CIRCE2 included again in WHIZARD 2 and validated 2010-09-02 Re-implementation of asymmetric beam energies and collision angles, e-p collisions work, inclusion of a HERA DIS test case ################################################################## 2010-10-18 RELEASE: version 2.0.3 2010-08-08 Bug in CP-violating anomalous triple TGCs fixed 2010-08-06 Solving backwards compatibility problem with O'Caml 3.12.0 2010-07-12 Conserved quantum numbers speed up O'Mega code generation 2010-07-07 Attaching full ISR/FSR parton shower and MPI/ISR module Added SM model containing Hgg, HAA, HAZ vertices 2010-07-02 Matching output available as LHEF and STDHEP 2010-06-30 Various bug fixes, missing files, typos 2010-06-26 CIRCE1 completely re-enabled Chaining structure functions supported 2010-06-25 Partial support for conserved quantum numbers in O'Mega 2010-06-21 Major upgrade of the graphics package: error bars, smarter SINDARIN steering, documentation, and all that... 2010-06-17 MLM matching with PYTHIA shower included 2010-06-16 Added full CIRCE1 and CIRCE2 versions including full documentation and miscellanea to the trunk 2010-06-12 User file management supported, improved variable and command structure 2010-05-24 Improved handling of variables in local command lists 2010-05-20 PYTHIA interface re-enabled 2010-05-19 ASCII file formats for interfacing ROOT and gnuplot in data analysis ################################################################## 2010-05-18 RELEASE: version 2.0.2 2010-05-14 Reimplementation of visualization of phase space channels Minor bug fixes 2010-05-12 Improved phase space - elimination of redundancies 2010-05-08 Interface for polarization completed: polarized beams etc. 2010-05-06 Full quantum numbers appear in process log Integration results are usable as user variables Communication with external programs 2010-05-05 Split module commands into commands, integration, simulation modules 2010-05-04 FSR+ISR for the first time connected to the WHIZARD 2 core ################################################################## 2010-04-25 RELEASE: version 2.0.1 2010-04-23 Automatic compile and integrate if simulate is called Minor bug fixes in O'Mega 2010-04-21 Checkpointing for event generation Flush statements to use WHIZARD inside a pipe 2010-04-20 Reimplementation of signal handling in WGIZARD 2.0 2010-04-19 VAMP is now a separately configurable and installable unit of WHIZARD, included VAMP self-checks Support again compilation in quadruple precision 2010-04-06 Allow for logarithmic plots in GAMELAN, reimplement the possibility to set the number of bins 2010-04-15 Improvement on time estimates for event generation ################################################################## 2010-04-12 RELEASE: version 2.0.0 2010-04-09 Per default, the code for the amplitudes is subdivided to allow faster compiler optimization More advanced and unified and straightforward command language syntax Final bug fixes 2010-04-07 Improvement on SINDARIN syntax; printf, sprintf function thorugh a C interface 2010-04-05 Colorizing DAGs instead of model vertices: speed boost in colored code generation 2010-03-31 Generalized options for normalization of weighted and unweighted events Grid and weight histories added again to log files Weights can be used in analyses 2010-03-28 Cascade decays completely implemented including color and spin correlations 2010-03-07 Added new WHIZARD header with logo 2010-03-05 Removed conflict in O'Mega amplitudes between flavour sums and cascades StdHEP interface re-implemented 2010-03-03 RELEASE: version 2.0.0rc3 Several bug fixes for preventing abuse in input files OpenMP support for amplitudes Reimplementation of WHIZARD 1 HEPEVT ASCII event formats FeynRules interface successfully passed MSSM test 2010-02-26 Eliminating ghost gluons from multi-gluon amplitudes 2010-02-25 RELEASE: version 1.95 HEPEVT format from WHIZARD 1 re-implemented in WHIZARD 2 2010-02-23 Running alpha_s implemented in the FeynRules interface 2010-02-19 MSSM (semi-) automatized self-tests finalized 2010-02-17 RELEASE: version 1.94 2010-02-16 Closed memory corruption in WHIZARD 1 Fixed problems of old MadGraph and CompHep drivers with modern compilers Uncolored vertex selection rules for colored amplitudes in O'Mega 2010-02-15 Infrastructure for color correlation computation in O'Mega finished Forbidden processes are warned about, but treated as non-fatal 2010-02-14 Color correlation computation in O'Mega finalized 2010-02-10 Improving phase space mappings for identical particles in initial and final states Introduction of more extended multi-line error message 2010-02-08 First O'Caml code for computation of color correlations in O'Mega 2010-02-07 First MLM matching with e+ e- -> jets ################################################################## 2010-02-06 RELEASE: version 2.0.0rc2 2010-02-05 Reconsidered the Makefile structure and more extended tests Catch a crash between WHIZARD and O'Mega for forbidden processes Tensor products of arbitrary color structures in jet definitions 2010-02-04 Color correlation computation in O'Mega finalized ################################################################## 2010-02-03 RELEASE: version 2.0.0rc1 ################################################################## 2010-01-31 Reimplemented numerical helicity selection rules Phase space functionality of version 1 restored and improved 2009-12-05 NMSSM validated with FeynRules in WHIZARD 1 (Felix Braam) 2009-12-04 RELEASE: version 2.0.0alpha ################################################################## 2009-04-16 RELEASE: version 1.93 2009-04-15 Clean-up of Makefiles and configure scripts Reconfiguration of BSM model implementation extended supersymmetric models 2008-12-23 New model NMSSM (Felix Braam) SLHA2 added Bug in LHAPDF interface fixed 2008-08-16 Bug fixed in K matrix implementation Gravitino option in the MSSM added 2008-03-20 Improved color and flavor sums ################################################################## 2008-03-12 RELEASE: version 1.92 LHEF (Les Houches Event File) format added Fortran 2003 command-line interface (if supported by the compiler) Automated interface to colored models More bug fixes and workarounds for compiler compatibility ################################################################## 2008-03-06 RELEASE: version 1.91 New model K-matrix (resonances and anom. couplings in WW scattering) EWA spectrum Energy-scan pseudo spectrum Preliminary parton shower module (only from final-state quarks) Cleanup and improvements of configure process Improvements for O'Mega parameter files Quadruple precision works again More plotting options: lines, symbols, errors Documentation with PDF bookmarks enabled Various bug fixes 2007-11-29 New model UED ################################################################## 2007-11-23 RELEASE: version 1.90 O'Mega now part of the WHIZARD tree Madgraph/CompHEP disabled by default (but still usable) Support for LHAPDF (preliminary) Added new models: SMZprime, SM_km, Template Improved compiler recognition and compatibility Minor bug fixes ################################################################## 2006-06-15 RELEASE: version 1.51 Support for anomaly-type Higgs couplings (to gluon and photon/Z) Support for spin 3/2 and spin 2 New models: Little Higgs (4 versions), toy models for extra dimensions and gravitinos Fixes to the whizard.nw source documentation to run through LaTeX Intel 9.0 bug workaround (deallocation of some arrays) 2006-05-15 O'Mega RELEASE: version 0.11 merged JRR's O'Mega extensions ################################################################## 2006-02-07 RELEASE: version 1.50 To avoid confusion: Mention outdated manual example in BUGS file O'Mega becomes part of the WHIZARD generator 2006-02-02 [bug fix update] Bug fix: spurious error when writing event files for weighted events Bug fix: 'r' option for omega produced garbage for some particle names Workaround for ifort90 bug (crash when compiling whizard_event) Workaround for ifort90 bug (crash when compiling hepevt_common) 2006-01-27 Added process definition files for MSSM 2->2 processes Included beam recoil for EPA (T.Barklow) Updated STDHEP byte counts (for STDHEP 5.04.02) Fixed STDHEP compatibility (avoid linking of incomplete .so libs) Fixed issue with comphep requiring Xlibs on Opteron Fixed issue with ifort 8.x on Opteron (compiling 'signal' interface) Fixed color-flow code: was broken for omega with option 'c' and 'w' Workaround hacks for g95 compatibility 2005-11-07 O'Mega RELEASE: version 0.10 O'Mega, merged JRR's and WK's color hack for WHiZard O'Mega, EXPERIMENTAL: cache fusion tables (required for colors a la JRR/WK) O'Mega, make JRR's MSSM official ################################################################## 2005-10-25 RELEASE: version 1.43 Minor fixes in MSSM couplings (Higgs/3rd gen squarks). This should be final, since the MSSM results agree now completely with Madgraph and Sherpa User-defined lower and upper limits for split event file count Allow for counters (events, bytes) exceeding $2^{31}$ Revised checksum treatment and implementation (now MD5) Bug fix: missing process energy scale in raw event file ################################################################## 2005-09-30 RELEASE: version 1.42 Graphical display of integration history ('make history') Allow for switching off signals even if supported (configure option) 2005-09-29 Revised phase space generation code, in particular for flavor sums Negative cut and histogram codes use initial beams instead of initial parton momenta. This allows for computing, e.g., E_miss Support constant-width and zero-width options for O'Mega Width options now denoted by w:X (X=f,c,z). f option obsolescent Bug fix: colorized code: flipped indices could screw up result Bug fix: O'Mega with 'c' and 'w:f' option together (still some problem) Bug fix: dvips on systems where dvips defaults to lpr Bug fix: integer overflow if too many events are requested 2005-07-29 Allow for 2 -> 1 processes (if structure functions are on) 2005-07-26 Fixed and expanded the 'test' matrix element: Unit matrix element with option 'u' / default: normalized phase space ################################################################## 2005-07-15 RELEASE: version 1.41 Bug fix: no result for particle decay processes with width=0 Bug fix: line breaks in O'Mega files with color decomposition 2005-06-02 New self-tests (make test-QED / test-QCD / test-SM) check lists of 2->2 processes Bug fix: HELAS calling convention for wwwwxx and jwwwxx (4W-Vertex) 2005-05-25 Revised Makefile structure Eliminated obsolete references to ISAJET/SUSY (superseded by SLHA) 2005-05-19 Support for color in O'Mega (using color flow decomposition) New model QCD Parameter file changes that correspond to replaced SM module in O'Mega Bug fixes in MSSM (O'Mega) parameter file 2005-05-18 New event file formats, useful for LHC applications: ATHENA and Les Houches Accord (external fragmentation) Naive (i.e., leading 1/N) color factor now implemented both for incoming and outgoing partons 2005-01-26 include missing HELAS files for bundle pgf90 compatibility issues [note: still internal error in pgf90] ################################################################## 2004-12-13 RELEASE: version 1.40 compatibility fix: preprocessor marks in helas code now commented out minor bug fix: format string in madgraph source 2004-12-03 support for arbitray beam energies and directions allow for pT kick in structure functions bug fix: rounding error could result in zero cross section (compiler-dependent) 2004-10-07 simulate decay processes list fraction (of total width/cross section) instead of efficiency in process summary new cut/analysis parameters AA, AAD, CTA: absolute polar angle 2004-10-04 Replaced Madgraph I by Madgraph II. Main improvement: model no longer hardcoded introduced parameter reset_seed_each_process (useful for debugging) bug fix: color initialization for some processes was undefined 2004-09-21 don't compile unix_args module if it is not required ################################################################## 2004-09-20 RELEASE: version 1.30 g95 compatibility issues resolved some (irrelevant) memory leaks closed removed obsolete warning in circe1 manual update (essentially) finished 2004-08-03 O'Mega RELEASE: version 0.9 O'Mega, src/trie.mli, src/trie.ml: make interface compatible with the O'Caml 3.08 library (remains compatible with older versions). Implementation of unused functions still incomplete. 2004-07-26 minor fixes and improvements in make process 2004-06-29 workarounds for new Intel compiler bugs ... no rebuild of madgraph/comphep executables after 'make clean' bug fix in phase space routine: wrong energy for massive initial particles bug fix in (new) model interface: name checks for antiparticles pre-run checks for comphep improved ww-strong model file extended Model files particle name fixes, chep SM vertices included 2004-06-22 O'Mega RELEASE: version 0.8 O'Mega MSSM: sign of W+/W-/A and W+/W-/Z couplings 2004-05-05 Fixed bug in PDFLIB interface: p+pbar was initialized as p+p (ThO) NAG compiler: set number of continuation lines to 200 as default Extended format for cross section summary; appears now in whizard.out Fixed 'bundle' feature 2004-04-28 Fixed compatibility with revised O'Mega SM_ac model Fixed problem with x=0 or x=1 when calling PDFLIB (ThO) Fixed bug in comphep module: Vtb was overlooked ################################################################## 2004-04-15 RELEASE: version 1.28 Fixed bug: Color factor was missing for O'Mega processes with four quarks and more Manual partially updated 2004-04-08 Support for grid files in binary format New default value show_histories=F (reduce output file size) Revised phase space switches: removed annihilation_lines, removed s_channel_resonance, changed meaning of extra_off_shell_lines, added show_deleted_channels Bug fixed which lead to omission of some phase space channels Color flow guessed only if requested by guess_color_flow 2004-03-10 New model interface: Only one model name specified in whizard.prc All model-dependent files reside in conf/models (modellib removed) 2004-03-03 Support for input/output in SUSY Les Houches Accord format Split event files if requested Support for overall time limit Support for CIRCE and CIRCE2 generator mode Support for reading beam events from file 2004-02-05 Fixed compiler problems with Intel Fortran 7.1 and 8.0 Support for catching signals ################################################################## 2003-08-06 RELEASE: version 1.27 User-defined PDF libraries as an alternative to the standard PDFLIB 2003-07-23 Revised phase space module: improved mappings for massless particles, equivalences of phase space channels are exploited Improved mapping for PDF (hadron colliders) Madgraph module: increased max number of color flows from 250 to 1000 ################################################################## 2003-06-23 RELEASE: version 1.26 CIRCE2 support Fixed problem with 'TC' integer kind [Intel compiler complained] 2003-05-28 Support for drawing histograms of grids Bug fixes for MSSM definitions ################################################################## 2003-05-22 RELEASE: version 1.25 Experimental MSSM support with ISAJET interface Improved capabilities of generating/analyzing weighted events Optional drawing phase space diagrams using FeynMF ################################################################## 2003-01-31 RELEASE: version 1.24 A few more fixes and workarounds (Intel and Lahey compiler) 2003-01-15 Fixes and workarounds needed for WHIZARD to run with Intel compiler Command-line option interface for the Lahey compiler Bug fix: problem with reading whizard.phs ################################################################## 2002-12-10 RELEASE: version 1.23 Command-line options (on some systems) Allow for initial particles in the event record, ordered: [beams, initials] - [remnants] - outgoing partons Support for PYTHIA 6.2: Les Houches external process interface String pythia_parameters can be up to 1000 characters long Select color flow states in (internal) analysis Bug fix in color flow content of raw event files Support for transversal polarization of fermion beams Cut codes: PHI now for absolute azimuthal angle, DPHI for distance 'Test' matrix elements optionally respect polarization User-defined code can be inserted for spectra, structure functions and fragmentation Time limits can be specified for adaptation and simulation User-defined file names and file directory Initial weights in input file no longer supported Bug fix in MadGraph (wave function counter could overflow) Bug fix: Gamelan (graphical analysis) was not built if noweb absent ################################################################## 2002-03-16 RELEASE: version 1.22 Allow for beam remnants in the event record 2002-03-01 Handling of aliases in whizard.prc fixed (aliases are whole tokens) 2002-02-28 Optimized phase space handling routines (total execution time reduced by 20-60%, depending on process) ################################################################## 2002-02-26 RELEASE: version 1.21 Fixed ISR formula (ISR was underestimated in previous versions). New version includes ISR in leading-log approximation up to third order. Parameter ISR_sqrts renamed to ISR_scale. ################################################################## 2002-02-19 RELEASE: version 1.20 New process-generating method 'test' (dummy matrix element) Compatibility with autoconf 2.50 and current O'Mega version 2002-02-05 Prevent integration channels from being dropped (optionally) New internal mapping for structure functions improves performance Old whizard.phx file deleted after recompiling (could cause trouble) 2002-01-24 Support for user-defined cuts and matrix element reweighting STDHEP output now written by write_events_format=20 (was 3) 2002-01-16 Improved structure function handling; small changes in user interface: new parameter structured_beams in &process_input parameter fixed_energy in &beam_input removed Support for multiple initial states Eta-phi (cone) cut possible (hadron collider applications) Fixed bug: Whizard library was not always recompiled when necessary Fixed bug: Default cuts were insufficient in some cases Fixed bug: Unusable phase space mappings generated in some cases 2001-12-06 Reorganized document source 2001-12-05 Preliminary CIRCE2 support (no functionality yet) 2001-11-27 Intel compiler support (does not yet work because of compiler bugs) New cut and analysis mode cos-theta* and related Fixed circular jetset_interface dependency warning Some broadcast routines removed (parallel support disabled anyway) Minor shifts in cleanup targets (Makefiles) Modified library search, check for pdflib8* 2001-08-06 Fixed bug: I/O unit number could be undefined when reading phase space Fixed bug: Unitialized variable could cause segfault when event generation was disabled Fixed bug: Undefined subroutine in CIRCE replacement module Enabled feature: TGCs in O'Mega (not yet CompHEP!) matrix elements (CompHEP model sm-GF #5, O'Mega model SM_ac) Fixed portability issue: Makefile did rely on PWD environment variable Fixed portability issue: PYTHIA library search ambiguity resolved 2001-08-01 Default whizard.prc and whizard.in depend on activated modules Fixed bug: TEX=latex was not properly enabled when making plots 2001-07-20 Fixed output settings in PERL script calls Cache enabled in various configure checks 2001-07-13 Support for multiple processes in a single WHIZARD run. The integrations are kept separate, but the generated events are mixed The whizard.evx format has changed (incompatible), including now the color flow information for PYTHIA fragmentation Output files are now process-specific, except for the event file Phase space file whizard.phs (if present) is used only as input, program-generated phase space is now in whizard.phx 2001-07-10 Bug fix: Undefined parameters in parameters_SM_ac.f90 removed 2001-07-04 Bug fix: Compiler options for the case OMEGA is disabled Small inconsistencies in whizard.out format fixed 2001-07-01 Workaround for missing PDFLIB dummy routines in PYTHIA library ################################################################## 2001-06-30 RELEASE: version 1.13 Default path /cern/pro/lib in configure script 2001-06-20 New fragmentation option: Interface for PYTHIA with full color flow information, beam remnants etc. 2001-06-18 Severe bug fixed in madgraph interface: 3-gluon coupling was missing Enabled color flow information in madgraph 2001-06-11 VAMP interface module rewritten Revised output format: Multiple VAMP iterations count as one WHIZARD iteration in integration passes 1 and 3 Improved message and error handling Bug fix in VAMP: handle exceptional cases in rebinning_weights 2001-05-31 new parameters for grid adaptation: accuracy_goal and efficiency_goal ################################################################## 2001-05-29 RELEASE: version 1.12 bug fixes (compilation problems): deleted/modified unused functions 2001-05-16 diagram selection improved and documented 2001-05-06 allow for disabling packages during configuration 2001-05-03 slight changes in whizard.out format; manual extended ################################################################## 2001-04-20 RELEASE: version 1.11 fixed some configuration and compilation problems (PDFLIB etc.) 2001-04-18 linked PDFLIB: support for quark/gluon structure functions 2001-04-05 parameter interface written by PERL script SM_ac model file: fixed error in continuation line 2001-03-13 O'Mega, O'Caml 3.01: incompatible changes O'Mega, src/trie.mli: add covariance annotation to T.t This breaks O'Caml 3.00, but is required for O'Caml 3.01. O'Mega, many instances: replace `sig include Module.T end' by `Module.T', since the bug is fixed in O'Caml 3.01 2001-02-28 O'Mega, src/model.mli: new field Model.vertices required for model functors, will retire Model.fuse2, Model.fuse3, Model.fusen soon. ################################################################## 2001-03-27 RELEASE: version 1.10 reorganized the modules as libraries linked PYTHIA: support for parton fragmentation 2000-12-14 fixed some configuration problems (if noweb etc. are absent) ################################################################## 2000-12-01 RELEASE of first public version: version 1.00beta Index: trunk/src/qft/qft.nw =================================================================== --- trunk/src/qft/qft.nw (revision 8456) +++ trunk/src/qft/qft.nw (revision 8457) @@ -1,15583 +1,15583 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: Quantum Field Theory concepts %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Quantum Field Theory Concepts} \includemodulegraph{qft} The objects and methods defined here implement concepts and data for the underlying quantum field theory that we use for computing matrix elements and processes. \begin{description} \item[model\_data] Fields and coupling parameters, operators as vertex structures, for a specific model. \item[model\_testbed] Provide hooks to deal with a [[model_data]] extension without referencing it explicitly. \item[helicities] Types and methods for spin density matrices. \item[colors] Dealing with colored particles, using the color-flow representation. \item[flavors] PDG codes and particle properties, depends on the model. \item[quantum\_numbers] Quantum numbers and density matrices for entangled particle systems. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Model Data} These data represent a specific Lagrangian in numeric terms. That is, we have the fields with their quantum numbers, the masses, widths and couplings as numerical values, and the vertices as arrays of fields. We do not store the relations between coupling parameters. They should be represented by expressions for evaluation, implemented as Sindarin objects in a distinct data structure. Neither do we need the algebraic structure of vertices. The field content of vertices is required for the sole purpose of setting up phase space. <<[[model_data.f90]]>>= <> module model_data use, intrinsic :: iso_c_binding !NODEP! <> use kinds, only: i8, i32 use kinds, only: c_default_float <> use format_defs, only: FMT_19 use io_units use diagnostics use md5 use hashes, only: hash use physics_defs, only: UNDEFINED, SCALAR <> <> <> <> contains <> end module model_data @ %def model_data @ \subsection{Physics Parameters} Couplings, masses, and widths are physics parameters. Each parameter has a unique name (used, essentially, for diagnostics output and debugging) and a value. The value may be a real or a complex number, so we provide to implementations of an abstract type. <>= public :: modelpar_data_t <>= type, abstract :: modelpar_data_t private type(string_t) :: name contains <> end type modelpar_data_t type, extends (modelpar_data_t) :: modelpar_real_t private real(default) :: value end type modelpar_real_t type, extends (modelpar_data_t) :: modelpar_complex_t private complex(default) :: value end type modelpar_complex_t @ %def modelpar_data_t modelpar_real_t modelpar_complex_t @ Output for diagnostics. Non-advancing. <>= procedure :: write => par_write <>= subroutine par_write (par, unit) class(modelpar_data_t), intent(in) :: par integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,1x,A)", advance="no") char (par%name), "= " select type (par) type is (modelpar_real_t) write (u, "(" // FMT_19 // ")", advance="no") par%value type is (modelpar_complex_t) write (u, "(" // FMT_19 // ",1x,'+',1x," // FMT_19 // ",1x,'I')", & advance="no") par%value end select end subroutine par_write @ %def par_write @ Pretty-printed on separate line, with fixed line length <>= procedure :: show => par_show <>= subroutine par_show (par, l, u) class(modelpar_data_t), intent(in) :: par integer, intent(in) :: l, u character(len=l) :: buffer buffer = par%name select type (par) type is (modelpar_real_t) write (u, "(4x,A,1x,'=',1x," // FMT_19 // ")") buffer, par%value type is (modelpar_complex_t) write (u, "(4x,A,1x,'=',1x," // FMT_19 // ",1x,'+',1x," & // FMT_19 // ",1x,'I')") buffer, par%value end select end subroutine par_show @ %def par_show @ Initialize with name and value. The type depends on the argument type. If the type does not match, the value is converted following Fortran rules. <>= generic :: init => modelpar_data_init_real, modelpar_data_init_complex procedure, private :: modelpar_data_init_real procedure, private :: modelpar_data_init_complex <>= subroutine modelpar_data_init_real (par, name, value) class(modelpar_data_t), intent(out) :: par type(string_t), intent(in) :: name real(default), intent(in) :: value par%name = name par = value end subroutine modelpar_data_init_real subroutine modelpar_data_init_complex (par, name, value) class(modelpar_data_t), intent(out) :: par type(string_t), intent(in) :: name complex(default), intent(in) :: value par%name = name par = value end subroutine modelpar_data_init_complex @ %def modelpar_data_init_real modelpar_data_init_complex @ Modify the value. We assume that the parameter has been initialized. The type (real or complex) must not be changed, and the name is also fixed. <>= generic :: assignment(=) => modelpar_data_set_real, modelpar_data_set_complex procedure, private :: modelpar_data_set_real procedure, private :: modelpar_data_set_complex <>= elemental subroutine modelpar_data_set_real (par, value) class(modelpar_data_t), intent(inout) :: par real(default), intent(in) :: value select type (par) type is (modelpar_real_t) par%value = value type is (modelpar_complex_t) par%value = value end select end subroutine modelpar_data_set_real elemental subroutine modelpar_data_set_complex (par, value) class(modelpar_data_t), intent(inout) :: par complex(default), intent(in) :: value select type (par) type is (modelpar_real_t) par%value = value type is (modelpar_complex_t) par%value = value end select end subroutine modelpar_data_set_complex @ %def modelpar_data_set_real modelpar_data_set_complex @ Return the parameter name. <>= procedure :: get_name => modelpar_data_get_name <>= function modelpar_data_get_name (par) result (name) class(modelpar_data_t), intent(in) :: par type(string_t) :: name name = par%name end function modelpar_data_get_name @ %def modelpar_data_get_name @ Return the value. In case of a type mismatch, follow Fortran conventions. <>= procedure, pass :: get_real => modelpar_data_get_real procedure, pass :: get_complex => modelpar_data_get_complex <>= elemental function modelpar_data_get_real (par) result (value) class(modelpar_data_t), intent(in), target :: par real(default) :: value select type (par) type is (modelpar_real_t) value = par%value type is (modelpar_complex_t) value = par%value end select end function modelpar_data_get_real elemental function modelpar_data_get_complex (par) result (value) class(modelpar_data_t), intent(in), target :: par complex(default) :: value select type (par) type is (modelpar_real_t) value = par%value type is (modelpar_complex_t) value = par%value end select end function modelpar_data_get_complex @ %def modelpar_data_get_real @ %def modelpar_data_get_complex @ Return a pointer to the value. This makes sense only for matching types. <>= procedure :: get_real_ptr => modelpar_data_get_real_ptr procedure :: get_complex_ptr => modelpar_data_get_complex_ptr <>= function modelpar_data_get_real_ptr (par) result (ptr) class(modelpar_data_t), intent(in), target :: par real(default), pointer :: ptr select type (par) type is (modelpar_real_t) ptr => par%value class default ptr => null () end select end function modelpar_data_get_real_ptr function modelpar_data_get_complex_ptr (par) result (ptr) class(modelpar_data_t), intent(in), target :: par complex(default), pointer :: ptr select type (par) type is (modelpar_complex_t) ptr => par%value class default ptr => null () end select end function modelpar_data_get_complex_ptr @ %def modelpar_data_get_real_ptr @ %def modelpar_data_get_complex_ptr @ \subsection{Field Data} The field-data type holds all information that pertains to a particular field (or particle) within a particular model. Information such as spin type, particle code etc.\ is stored within the object itself, while mass and width are associated to parameters, otherwise assumed zero. <>= public :: field_data_t <>= type :: field_data_t private type(string_t) :: longname integer :: pdg = UNDEFINED logical :: visible = .true. logical :: parton = .false. logical :: gauge = .false. logical :: left_handed = .false. logical :: right_handed = .false. logical :: has_anti = .false. logical :: p_is_stable = .true. logical :: p_decays_isotropically = .false. logical :: p_decays_diagonal = .false. logical :: p_has_decay_helicity = .false. integer :: p_decay_helicity = 0 logical :: a_is_stable = .true. logical :: a_decays_isotropically = .false. logical :: a_decays_diagonal = .false. logical :: a_has_decay_helicity = .false. integer :: a_decay_helicity = 0 logical :: p_polarized = .false. logical :: a_polarized = .false. type(string_t), dimension(:), allocatable :: name, anti type(string_t) :: tex_name, tex_anti integer :: spin_type = UNDEFINED integer :: isospin_type = 1 integer :: charge_type = 1 integer :: color_type = 1 real(default), pointer :: mass_val => null () class(modelpar_data_t), pointer :: mass_data => null () real(default), pointer :: width_val => null () class(modelpar_data_t), pointer :: width_data => null () integer :: multiplicity = 1 type(string_t), dimension(:), allocatable :: p_decay type(string_t), dimension(:), allocatable :: a_decay contains <> end type field_data_t @ %def field_data_t @ Initialize field data with PDG long name and PDG code. \TeX\ names should be initialized to avoid issues with accessing unallocated string contents. <>= procedure :: init => field_data_init <>= subroutine field_data_init (prt, longname, pdg) class(field_data_t), intent(out) :: prt type(string_t), intent(in) :: longname integer, intent(in) :: pdg prt%longname = longname prt%pdg = pdg prt%tex_name = "" prt%tex_anti = "" end subroutine field_data_init @ %def field_data_init @ Copy quantum numbers from another particle. Do not compute the multiplicity yet, because this depends on the association of the [[mass_data]] pointer. <>= procedure :: copy_from => field_data_copy_from <>= subroutine field_data_copy_from (prt, prt_src) class(field_data_t), intent(inout) :: prt class(field_data_t), intent(in) :: prt_src prt%visible = prt_src%visible prt%parton = prt_src%parton prt%gauge = prt_src%gauge prt%left_handed = prt_src%left_handed prt%right_handed = prt_src%right_handed prt%p_is_stable = prt_src%p_is_stable prt%p_decays_isotropically = prt_src%p_decays_isotropically prt%p_decays_diagonal = prt_src%p_decays_diagonal prt%p_has_decay_helicity = prt_src%p_has_decay_helicity prt%p_decay_helicity = prt_src%p_decay_helicity prt%p_decays_diagonal = prt_src%p_decays_diagonal prt%a_is_stable = prt_src%a_is_stable prt%a_decays_isotropically = prt_src%a_decays_isotropically prt%a_decays_diagonal = prt_src%a_decays_diagonal prt%a_has_decay_helicity = prt_src%a_has_decay_helicity prt%a_decay_helicity = prt_src%a_decay_helicity prt%p_polarized = prt_src%p_polarized prt%a_polarized = prt_src%a_polarized prt%spin_type = prt_src%spin_type prt%isospin_type = prt_src%isospin_type prt%charge_type = prt_src%charge_type prt%color_type = prt_src%color_type prt%has_anti = prt_src%has_anti if (allocated (prt_src%name)) then if (allocated (prt%name)) deallocate (prt%name) allocate (prt%name (size (prt_src%name)), source = prt_src%name) end if if (allocated (prt_src%anti)) then if (allocated (prt%anti)) deallocate (prt%anti) allocate (prt%anti (size (prt_src%anti)), source = prt_src%anti) end if prt%tex_name = prt_src%tex_name prt%tex_anti = prt_src%tex_anti if (allocated (prt_src%p_decay)) then if (allocated (prt%p_decay)) deallocate (prt%p_decay) allocate (prt%p_decay (size (prt_src%p_decay)), source = prt_src%p_decay) end if if (allocated (prt_src%a_decay)) then if (allocated (prt%a_decay)) deallocate (prt%a_decay) allocate (prt%a_decay (size (prt_src%a_decay)), source = prt_src%a_decay) end if end subroutine field_data_copy_from @ %def field_data_copy_from @ Set particle quantum numbers. <>= procedure :: set => field_data_set <>= subroutine field_data_set (prt, & is_visible, is_parton, is_gauge, is_left_handed, is_right_handed, & p_is_stable, p_decays_isotropically, p_decays_diagonal, & p_decay_helicity, & a_is_stable, a_decays_isotropically, a_decays_diagonal, & a_decay_helicity, & p_polarized, a_polarized, & name, anti, tex_name, tex_anti, & spin_type, isospin_type, charge_type, color_type, & mass_data, width_data, & p_decay, a_decay) class(field_data_t), intent(inout) :: prt logical, intent(in), optional :: is_visible, is_parton, is_gauge logical, intent(in), optional :: is_left_handed, is_right_handed logical, intent(in), optional :: p_is_stable logical, intent(in), optional :: p_decays_isotropically, p_decays_diagonal integer, intent(in), optional :: p_decay_helicity logical, intent(in), optional :: a_is_stable logical, intent(in), optional :: a_decays_isotropically, a_decays_diagonal integer, intent(in), optional :: a_decay_helicity logical, intent(in), optional :: p_polarized, a_polarized type(string_t), dimension(:), intent(in), optional :: name, anti type(string_t), intent(in), optional :: tex_name, tex_anti integer, intent(in), optional :: spin_type, isospin_type integer, intent(in), optional :: charge_type, color_type class(modelpar_data_t), intent(in), pointer, optional :: mass_data, width_data type(string_t), dimension(:), intent(in), optional :: p_decay, a_decay if (present (is_visible)) prt%visible = is_visible if (present (is_parton)) prt%parton = is_parton if (present (is_gauge)) prt%gauge = is_gauge if (present (is_left_handed)) prt%left_handed = is_left_handed if (present (is_right_handed)) prt%right_handed = is_right_handed if (present (p_is_stable)) prt%p_is_stable = p_is_stable if (present (p_decays_isotropically)) & prt%p_decays_isotropically = p_decays_isotropically if (present (p_decays_diagonal)) & prt%p_decays_diagonal = p_decays_diagonal if (present (p_decay_helicity)) then prt%p_has_decay_helicity = .true. prt%p_decay_helicity = p_decay_helicity end if if (present (a_is_stable)) prt%a_is_stable = a_is_stable if (present (a_decays_isotropically)) & prt%a_decays_isotropically = a_decays_isotropically if (present (a_decays_diagonal)) & prt%a_decays_diagonal = a_decays_diagonal if (present (a_decay_helicity)) then prt%a_has_decay_helicity = .true. prt%a_decay_helicity = a_decay_helicity end if if (present (p_polarized)) prt%p_polarized = p_polarized if (present (a_polarized)) prt%a_polarized = a_polarized if (present (name)) then if (allocated (prt%name)) deallocate (prt%name) allocate (prt%name (size (name)), source = name) end if if (present (anti)) then if (allocated (prt%anti)) deallocate (prt%anti) allocate (prt%anti (size (anti)), source = anti) prt%has_anti = .true. end if if (present (tex_name)) prt%tex_name = tex_name if (present (tex_anti)) prt%tex_anti = tex_anti if (present (spin_type)) prt%spin_type = spin_type if (present (isospin_type)) prt%isospin_type = isospin_type if (present (charge_type)) prt%charge_type = charge_type if (present (color_type)) prt%color_type = color_type if (present (mass_data)) then prt%mass_data => mass_data if (associated (mass_data)) then prt%mass_val => mass_data%get_real_ptr () else prt%mass_val => null () end if end if if (present (width_data)) then prt%width_data => width_data if (associated (width_data)) then prt%width_val => width_data%get_real_ptr () else prt%width_val => null () end if end if if (present (spin_type) .or. present (mass_data)) then call prt%set_multiplicity () end if if (present (p_decay)) then if (allocated (prt%p_decay)) deallocate (prt%p_decay) if (size (p_decay) > 0) & allocate (prt%p_decay (size (p_decay)), source = p_decay) end if if (present (a_decay)) then if (allocated (prt%a_decay)) deallocate (prt%a_decay) if (size (a_decay) > 0) & allocate (prt%a_decay (size (a_decay)), source = a_decay) end if end subroutine field_data_set @ %def field_data_set @ Calculate the multiplicity given spin type and mass. <>= procedure, private :: & set_multiplicity => field_data_set_multiplicity <>= subroutine field_data_set_multiplicity (prt) class(field_data_t), intent(inout) :: prt if (prt%spin_type /= SCALAR) then if (associated (prt%mass_data)) then prt%multiplicity = prt%spin_type else if (prt%left_handed .or. prt%right_handed) then prt%multiplicity = 1 else prt%multiplicity = 2 end if end if end subroutine field_data_set_multiplicity @ %def field_data_set_multiplicity @ Set the mass/width value (not the pointer). The mass/width pointer must be allocated. <>= procedure, private :: set_mass => field_data_set_mass procedure, private :: set_width => field_data_set_width <>= subroutine field_data_set_mass (prt, mass) class(field_data_t), intent(inout) :: prt real(default), intent(in) :: mass if (associated (prt%mass_val)) prt%mass_val = mass end subroutine field_data_set_mass subroutine field_data_set_width (prt, width) class(field_data_t), intent(inout) :: prt real(default), intent(in) :: width if (associated (prt%width_val)) prt%width_val = width end subroutine field_data_set_width @ %def field_data_set_mass field_data_set_width @ Loose ends: name arrays should be allocated. <>= procedure :: freeze => field_data_freeze <>= elemental subroutine field_data_freeze (prt) class(field_data_t), intent(inout) :: prt if (.not. allocated (prt%name)) allocate (prt%name (0)) if (.not. allocated (prt%anti)) allocate (prt%anti (0)) end subroutine field_data_freeze @ %def field_data_freeze @ Output <>= procedure :: write => field_data_write <>= subroutine field_data_write (prt, unit) class(field_data_t), intent(in) :: prt integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A,1x,A)", advance="no") "particle", char (prt%longname) write (u, "(1x,I0)", advance="no") prt%pdg if (.not. prt%visible) write (u, "(2x,A)", advance="no") "invisible" if (prt%parton) write (u, "(2x,A)", advance="no") "parton" if (prt%gauge) write (u, "(2x,A)", advance="no") "gauge" if (prt%left_handed) write (u, "(2x,A)", advance="no") "left" if (prt%right_handed) write (u, "(2x,A)", advance="no") "right" write (u, *) write (u, "(5x,A)", advance="no") "name" if (allocated (prt%name)) then do i = 1, size (prt%name) write (u, "(1x,A)", advance="no") '"' // char (prt%name(i)) // '"' end do write (u, *) if (prt%has_anti) then write (u, "(5x,A)", advance="no") "anti" do i = 1, size (prt%anti) write (u, "(1x,A)", advance="no") '"' // char (prt%anti(i)) // '"' end do write (u, *) end if if (prt%tex_name /= "") then write (u, "(5x,A)") & "tex_name " // '"' // char (prt%tex_name) // '"' end if if (prt%has_anti .and. prt%tex_anti /= "") then write (u, "(5x,A)") & "tex_anti " // '"' // char (prt%tex_anti) // '"' end if else write (u, "(A)") "???" end if write (u, "(5x,A)", advance="no") "spin " select case (mod (prt%spin_type - 1, 2)) case (0); write (u, "(I0)", advance="no") (prt%spin_type-1) / 2 case default; write (u, "(I0,A)", advance="no") prt%spin_type-1, "/2" end select ! write (u, "(2x,A,I1,A)") "! [multiplicity = ", prt%multiplicity, "]" if (abs (prt%isospin_type) /= 1) then write (u, "(2x,A)", advance="no") "isospin " select case (mod (abs (prt%isospin_type) - 1, 2)) case (0); write (u, "(I0)", advance="no") & sign (abs (prt%isospin_type) - 1, prt%isospin_type) / 2 case default; write (u, "(I0,A)", advance="no") & sign (abs (prt%isospin_type) - 1, prt%isospin_type), "/2" end select end if if (abs (prt%charge_type) /= 1) then write (u, "(2x,A)", advance="no") "charge " select case (mod (abs (prt%charge_type) - 1, 3)) case (0); write (u, "(I0)", advance="no") & sign (abs (prt%charge_type) - 1, prt%charge_type) / 3 case default; write (u, "(I0,A)", advance="no") & sign (abs (prt%charge_type) - 1, prt%charge_type), "/3" end select end if if (prt%color_type /= 1) then write (u, "(2x,A,I0)", advance="no") "color ", prt%color_type end if write (u, *) if (associated (prt%mass_data)) then write (u, "(5x,A)", advance="no") & "mass " // char (prt%mass_data%get_name ()) if (associated (prt%width_data)) then write (u, "(2x,A)") & "width " // char (prt%width_data%get_name ()) else write (u, *) end if end if call prt%write_decays (u) end subroutine field_data_write @ %def field_data_write @ Write decay and polarization data. <>= procedure :: write_decays => field_data_write_decays <>= subroutine field_data_write_decays (prt, unit) class(field_data_t), intent(in) :: prt integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) if (.not. prt%p_is_stable) then if (allocated (prt%p_decay)) then write (u, "(5x,A)", advance="no") "p_decay" do i = 1, size (prt%p_decay) write (u, "(1x,A)", advance="no") char (prt%p_decay(i)) end do if (prt%p_decays_isotropically) then write (u, "(1x,A)", advance="no") "isotropic" else if (prt%p_decays_diagonal) then write (u, "(1x,A)", advance="no") "diagonal" else if (prt%p_has_decay_helicity) then write (u, "(1x,A,I0)", advance="no") "helicity = ", & prt%p_decay_helicity end if write (u, *) end if else if (prt%p_polarized) then write (u, "(5x,A)") "p_polarized" end if if (.not. prt%a_is_stable) then if (allocated (prt%a_decay)) then write (u, "(5x,A)", advance="no") "a_decay" do i = 1, size (prt%a_decay) write (u, "(1x,A)", advance="no") char (prt%a_decay(i)) end do if (prt%a_decays_isotropically) then write (u, "(1x,A)", advance="no") "isotropic" else if (prt%a_decays_diagonal) then write (u, "(1x,A)", advance="no") "diagonal" else if (prt%a_has_decay_helicity) then write (u, "(1x,A,I0)", advance="no") "helicity = ", & prt%a_decay_helicity end if write (u, *) end if else if (prt%a_polarized) then write (u, "(5x,A)") "a_polarized" end if end subroutine field_data_write_decays @ %def field_data_write_decays @ Screen version of output. <>= procedure :: show => field_data_show <>= subroutine field_data_show (prt, l, u) class(field_data_t), intent(in) :: prt integer, intent(in) :: l, u character(len=l) :: buffer integer :: i type(string_t), dimension(:), allocatable :: decay buffer = prt%get_name (.false.) write (u, "(4x,A,1x,I8)", advance="no") buffer, & prt%get_pdg () if (prt%is_polarized ()) then write (u, "(3x,A)") "polarized" else if (.not. prt%is_stable ()) then write (u, "(3x,A)", advance="no") "decays:" call prt%get_decays (decay) do i = 1, size (decay) write (u, "(1x,A)", advance="no") char (decay(i)) end do write (u, *) else write (u, *) end if if (prt%has_antiparticle ()) then buffer = prt%get_name (.true.) write (u, "(4x,A,1x,I8)", advance="no") buffer, & prt%get_pdg_anti () if (prt%is_polarized (.true.)) then write (u, "(3x,A)") "polarized" else if (.not. prt%is_stable (.true.)) then write (u, "(3x,A)", advance="no") "decays:" call prt%get_decays (decay, .true.) do i = 1, size (decay) write (u, "(1x,A)", advance="no") char (decay(i)) end do write (u, *) else write (u, *) end if end if end subroutine field_data_show @ %def field_data_show @ Retrieve data: <>= procedure :: get_pdg => field_data_get_pdg procedure :: get_pdg_anti => field_data_get_pdg_anti <>= elemental function field_data_get_pdg (prt) result (pdg) integer :: pdg class(field_data_t), intent(in) :: prt pdg = prt%pdg end function field_data_get_pdg elemental function field_data_get_pdg_anti (prt) result (pdg) integer :: pdg class(field_data_t), intent(in) :: prt if (prt%has_anti) then pdg = - prt%pdg else pdg = prt%pdg end if end function field_data_get_pdg_anti @ %def field_data_get_pdg field_data_get_pdg_anti @ Predicates: <>= procedure :: is_visible => field_data_is_visible procedure :: is_parton => field_data_is_parton procedure :: is_gauge => field_data_is_gauge procedure :: is_left_handed => field_data_is_left_handed procedure :: is_right_handed => field_data_is_right_handed procedure :: has_antiparticle => field_data_has_antiparticle procedure :: is_stable => field_data_is_stable procedure :: get_decays => field_data_get_decays procedure :: decays_isotropically => field_data_decays_isotropically procedure :: decays_diagonal => field_data_decays_diagonal procedure :: has_decay_helicity => field_data_has_decay_helicity procedure :: decay_helicity => field_data_decay_helicity procedure :: is_polarized => field_data_is_polarized <>= elemental function field_data_is_visible (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%visible end function field_data_is_visible elemental function field_data_is_parton (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%parton end function field_data_is_parton elemental function field_data_is_gauge (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%gauge end function field_data_is_gauge elemental function field_data_is_left_handed (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%left_handed end function field_data_is_left_handed elemental function field_data_is_right_handed (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%right_handed end function field_data_is_right_handed elemental function field_data_has_antiparticle (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%has_anti end function field_data_has_antiparticle elemental function field_data_is_stable (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then flag = prt%a_is_stable else flag = prt%p_is_stable end if else flag = prt%p_is_stable end if end function field_data_is_stable subroutine field_data_get_decays (prt, decay, anti) class(field_data_t), intent(in) :: prt type(string_t), dimension(:), intent(out), allocatable :: decay logical, intent(in), optional :: anti if (present (anti)) then if (anti) then allocate (decay (size (prt%a_decay)), source = prt%a_decay) else allocate (decay (size (prt%p_decay)), source = prt%p_decay) end if else allocate (decay (size (prt%p_decay)), source = prt%p_decay) end if end subroutine field_data_get_decays elemental function field_data_decays_isotropically & (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then flag = prt%a_decays_isotropically else flag = prt%p_decays_isotropically end if else flag = prt%p_decays_isotropically end if end function field_data_decays_isotropically elemental function field_data_decays_diagonal & (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then flag = prt%a_decays_diagonal else flag = prt%p_decays_diagonal end if else flag = prt%p_decays_diagonal end if end function field_data_decays_diagonal elemental function field_data_has_decay_helicity & (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then flag = prt%a_has_decay_helicity else flag = prt%p_has_decay_helicity end if else flag = prt%p_has_decay_helicity end if end function field_data_has_decay_helicity elemental function field_data_decay_helicity & (prt, anti) result (hel) integer :: hel class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then hel = prt%a_decay_helicity else hel = prt%p_decay_helicity end if else hel = prt%p_decay_helicity end if end function field_data_decay_helicity elemental function field_data_is_polarized (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti logical :: a if (present (anti)) then a = anti else a = .false. end if if (a) then flag = prt%a_polarized else flag = prt%p_polarized end if end function field_data_is_polarized @ %def field_data_is_visible field_data_is_parton @ %def field_data_is_gauge @ %def field_data_is_left_handed field_data_is_right_handed @ %def field_data_has_antiparticle @ %def field_data_is_stable @ %def field_data_decays_isotropically @ %def field_data_decays_diagonal @ %def field_data_has_decay_helicity @ %def field_data_decay_helicity @ %def field_data_polarized @ Names. Return the first name in the list (or the first antiparticle name) <>= procedure :: get_longname => field_data_get_longname procedure :: get_name => field_data_get_name procedure :: get_name_array => field_data_get_name_array <>= pure function field_data_get_longname (prt) result (name) type(string_t) :: name class(field_data_t), intent(in) :: prt name = prt%longname end function field_data_get_longname pure function field_data_get_name (prt, is_antiparticle) result (name) type(string_t) :: name class(field_data_t), intent(in) :: prt logical, intent(in) :: is_antiparticle name = prt%longname if (is_antiparticle) then if (prt%has_anti) then if (allocated (prt%anti)) then if (size(prt%anti) > 0) name = prt%anti(1) end if else if (allocated (prt%name)) then if (size (prt%name) > 0) name = prt%name(1) end if end if else if (allocated (prt%name)) then if (size (prt%name) > 0) name = prt%name(1) end if end if end function field_data_get_name subroutine field_data_get_name_array (prt, is_antiparticle, name) class(field_data_t), intent(in) :: prt logical, intent(in) :: is_antiparticle type(string_t), dimension(:), allocatable, intent(inout) :: name if (allocated (name)) deallocate (name) if (is_antiparticle) then if (prt%has_anti) then allocate (name (size (prt%anti))) name = prt%anti else allocate (name (0)) end if else allocate (name (size (prt%name))) name = prt%name end if end subroutine field_data_get_name_array @ %def field_data_get_name @ Same for the \TeX\ name. <>= procedure :: get_tex_name => field_data_get_tex_name <>= elemental function field_data_get_tex_name & (prt, is_antiparticle) result (name) type(string_t) :: name class(field_data_t), intent(in) :: prt logical, intent(in) :: is_antiparticle if (is_antiparticle) then if (prt%has_anti) then name = prt%tex_anti else name = prt%tex_name end if else name = prt%tex_name end if if (name == "") name = prt%get_name (is_antiparticle) end function field_data_get_tex_name @ %def field_data_get_tex_name @ Check if any of the field names matches the given string. <>= procedure, private :: matches_name => field_data_matches_name <>= function field_data_matches_name (field, name, is_antiparticle) result (flag) class(field_data_t), intent(in) :: field type(string_t), intent(in) :: name logical, intent(in) :: is_antiparticle logical :: flag if (is_antiparticle) then if (field%has_anti) then flag = any (name == field%anti) else flag = .false. end if else flag = name == field%longname .or. any (name == field%name) end if end function field_data_matches_name @ %def field_data_matches_name @ Quantum numbers <>= procedure :: get_spin_type => field_data_get_spin_type procedure :: get_multiplicity => field_data_get_multiplicity procedure :: get_isospin_type => field_data_get_isospin_type procedure :: get_charge_type => field_data_get_charge_type procedure :: get_color_type => field_data_get_color_type <>= elemental function field_data_get_spin_type (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%spin_type end function field_data_get_spin_type elemental function field_data_get_multiplicity (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%multiplicity end function field_data_get_multiplicity elemental function field_data_get_isospin_type (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%isospin_type end function field_data_get_isospin_type elemental function field_data_get_charge_type (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%charge_type end function field_data_get_charge_type elemental function field_data_get_color_type (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%color_type end function field_data_get_color_type @ %def field_data_get_spin_type @ %def field_data_get_multiplicity @ %def field_data_get_isospin_type @ %def field_data_get_charge_type @ %def field_data_get_color_type @ In the MSSM, neutralinos can have a negative mass. This is relevant for computing matrix elements. However, within the \whizard\ main program we are interested only in kinematics, therefore we return the absolute value of the particle mass. If desired, we can extract the sign separately. <>= procedure :: get_charge => field_data_get_charge procedure :: get_isospin => field_data_get_isospin procedure :: get_mass => field_data_get_mass procedure :: get_mass_sign => field_data_get_mass_sign procedure :: get_width => field_data_get_width <>= elemental function field_data_get_charge (prt) result (charge) real(default) :: charge class(field_data_t), intent(in) :: prt if (prt%charge_type /= 0) then charge = real (sign ((abs(prt%charge_type) - 1), & prt%charge_type), default) / 3 else charge = 0 end if end function field_data_get_charge elemental function field_data_get_isospin (prt) result (isospin) real(default) :: isospin class(field_data_t), intent(in) :: prt if (prt%isospin_type /= 0) then isospin = real (sign (abs(prt%isospin_type) - 1, & prt%isospin_type), default) / 2 else isospin = 0 end if end function field_data_get_isospin elemental function field_data_get_mass (prt) result (mass) real(default) :: mass class(field_data_t), intent(in) :: prt if (associated (prt%mass_val)) then mass = abs (prt%mass_val) else mass = 0 end if end function field_data_get_mass elemental function field_data_get_mass_sign (prt) result (sgn) integer :: sgn class(field_data_t), intent(in) :: prt if (associated (prt%mass_val)) then sgn = sign (1._default, prt%mass_val) else sgn = 0 end if end function field_data_get_mass_sign elemental function field_data_get_width (prt) result (width) real(default) :: width class(field_data_t), intent(in) :: prt if (associated (prt%width_val)) then width = prt%width_val else width = 0 end if end function field_data_get_width @ %def field_data_get_charge field_data_get_isospin @ %def field_data_get_mass field_data_get_mass_sign @ %def field_data_get_width @ Find the [[model]] containing the [[PDG]] given two model files. <>= public :: find_model <>= subroutine find_model (model, PDG, model_A, model_B) class(model_data_t), pointer, intent(out) :: model integer, intent(in) :: PDG class(model_data_t), intent(in), target :: model_A, model_B character(len=10) :: buffer if (model_A%test_field (PDG)) then model => model_A else if (model_B%test_field (PDG)) then model => model_B else call model_A%write () call model_B%write () write (buffer, "(I10)") PDG call msg_fatal ("Parton " // buffer // & " not found in the given model files") end if end subroutine find_model @ %def find_model @ \subsection{Vertex data} The vertex object contains an array of particle-data pointers, for which we need a separate type. (We could use the flavor type defined in another module.) The program does not (yet?) make use of vertex definitions, so they are not stored here. <>= type :: field_data_p type(field_data_t), pointer :: p => null () end type field_data_p @ %def field_data_p <>= type :: vertex_t private logical :: trilinear integer, dimension(:), allocatable :: pdg type(field_data_p), dimension(:), allocatable :: prt contains <> end type vertex_t @ %def vertex_t <>= procedure :: write => vertex_write <>= subroutine vertex_write (vtx, unit) class(vertex_t), intent(in) :: vtx integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(3x,A)", advance="no") "vertex" do i = 1, size (vtx%prt) if (associated (vtx%prt(i)%p)) then write (u, "(1x,A)", advance="no") & '"' // char (vtx%prt(i)%p%get_name (vtx%pdg(i) < 0)) & // '"' else write (u, "(1x,I7)", advance="no") vtx%pdg(i) end if end do write (u, *) end subroutine vertex_write @ %def vertex_write @ Initialize using PDG codes. The model is used for finding particle data pointers associated with the pdg codes. <>= procedure :: init => vertex_init <>= subroutine vertex_init (vtx, pdg, model) class(vertex_t), intent(out) :: vtx integer, dimension(:), intent(in) :: pdg type(model_data_t), intent(in), target, optional :: model integer :: i allocate (vtx%pdg (size (pdg))) allocate (vtx%prt (size (pdg))) vtx%trilinear = size (pdg) == 3 vtx%pdg = pdg if (present (model)) then do i = 1, size (pdg) vtx%prt(i)%p => model%get_field_ptr (pdg(i)) end do end if end subroutine vertex_init @ %def vertex_init @ Copy vertex: we must reassign the field-data pointer to a new model. <>= procedure :: copy_from => vertex_copy_from <>= subroutine vertex_copy_from (vtx, old_vtx, new_model) class(vertex_t), intent(out) :: vtx class(vertex_t), intent(in) :: old_vtx type(model_data_t), intent(in), target, optional :: new_model call vtx%init (old_vtx%pdg, new_model) end subroutine vertex_copy_from @ %def vertex_copy_from @ Single-particle lookup: Given a particle code, we return matching codes if present, otherwise zero. Actually, we return the antiparticles of the matching codes, as appropriate for computing splittings. <>= procedure :: get_match => vertex_get_match <>= subroutine vertex_get_match (vtx, pdg1, pdg2) class(vertex_t), intent(in) :: vtx integer, intent(in) :: pdg1 integer, dimension(:), allocatable, intent(out) :: pdg2 integer :: i, j do i = 1, size (vtx%pdg) if (vtx%pdg(i) == pdg1) then allocate (pdg2 (size (vtx%pdg) - 1)) do j = 1, i-1 pdg2(j) = anti (j) end do do j = i, size (pdg2) pdg2(j) = anti (j+1) end do exit end if end do contains function anti (i) result (pdg) integer, intent(in) :: i integer :: pdg if (vtx%prt(i)%p%has_antiparticle ()) then pdg = - vtx%pdg(i) else pdg = vtx%pdg(i) end if end function anti end subroutine vertex_get_match @ %def vertex_get_match @ To access this from the outside, we create an iterator. The iterator has the sole purpose of returning the matching particles for a given array of PDG codes. <>= public :: vertex_iterator_t <>= type :: vertex_iterator_t private class(model_data_t), pointer :: model => null () integer, dimension(:), allocatable :: pdg integer :: vertex_index = 0 integer :: pdg_index = 0 logical :: save_pdg_index contains procedure :: init => vertex_iterator_init procedure :: get_next_match => vertex_iterator_get_next_match end type vertex_iterator_t @ %def vertex_iterator_t @ We initialize the iterator for a particular model with the [[pdg]] index of the particle we are looking at. <>= subroutine vertex_iterator_init (it, model, pdg, save_pdg_index) class(vertex_iterator_t), intent(out) :: it class(model_data_t), intent(in), target :: model integer, dimension(:), intent(in) :: pdg logical, intent(in) :: save_pdg_index it%model => model allocate (it%pdg (size (pdg)), source = pdg) it%save_pdg_index = save_pdg_index end subroutine vertex_iterator_init subroutine vertex_iterator_get_next_match (it, pdg_match) class(vertex_iterator_t), intent(inout) :: it integer, dimension(:), allocatable, intent(out) :: pdg_match integer :: i, j do i = it%vertex_index + 1, size (it%model%vtx) do j = it%pdg_index + 1, size (it%pdg) call it%model%vtx(i)%get_match (it%pdg(j), pdg_match) if (it%save_pdg_index) then if (allocated (pdg_match) .and. j < size (it%pdg)) then it%pdg_index = j return else if (allocated (pdg_match) .and. j == size (it%pdg)) then it%vertex_index = i it%pdg_index = 0 return end if else if (allocated (pdg_match)) then it%vertex_index = i return end if end do end do it%vertex_index = 0 it%pdg_index = 0 end subroutine vertex_iterator_get_next_match @ %def vertex_iterator_get_next_match @ \subsection{Vertex lookup table} The vertex lookup table is a hash table: given two particle codes, we check which codes are allowed for the third one. The size of the hash table should be large enough that collisions are rare. We first select a size based on the number of vertices (multiplied by six because all permutations count), with some margin, and then choose the smallest integer power of two larger than this. <>= integer, parameter :: VERTEX_TABLE_SCALE_FACTOR = 60 @ %def VERTEX_TABLE_SCALE_FACTOR <>= function vertex_table_size (n_vtx) result (n) integer(i32) :: n integer, intent(in) :: n_vtx integer :: i, s s = VERTEX_TABLE_SCALE_FACTOR * n_vtx n = 1 do i = 1, 31 n = ishft (n, 1) s = ishft (s,-1) if (s == 0) exit end do end function vertex_table_size @ %def vertex_table_size @ The specific hash function takes two particle codes (arbitrary integers) and returns a 32-bit integer. It makes use of the universal function [[hash]] which operates on a byte array. <>= function hash2 (pdg1, pdg2) integer(i32) :: hash2 integer, intent(in) :: pdg1, pdg2 integer(i8), dimension(1) :: mold hash2 = hash (transfer ([pdg1, pdg2], mold)) end function hash2 @ %def hash2 @ Each entry in the vertex table stores the two particle codes and an array of possibilities for the third code. <>= type :: vertex_table_entry_t private integer :: pdg1 = 0, pdg2 = 0 integer :: n = 0 integer, dimension(:), allocatable :: pdg3 end type vertex_table_entry_t @ %def vertex_table_entry_t @ The vertex table: <>= type :: vertex_table_t type(vertex_table_entry_t), dimension(:), allocatable :: entry integer :: n_collisions = 0 integer(i32) :: mask contains <> end type vertex_table_t @ %def vertex_table_t @ Output. <>= procedure :: write => vertex_table_write <>= subroutine vertex_table_write (vt, unit) class(vertex_table_t), intent(in) :: vt integer, intent(in), optional :: unit integer :: u, i character(9) :: size_pdg3 u = given_output_unit (unit) write (u, "(A)") "vertex hash table:" write (u, "(A,I7)") " size = ", size (vt%entry) write (u, "(A,I7)") " used = ", count (vt%entry%n /= 0) write (u, "(A,I7)") " coll = ", vt%n_collisions do i = lbound (vt%entry, 1), ubound (vt%entry, 1) if (vt%entry(i)%n /= 0) then write (size_pdg3, "(I7)") size (vt%entry(i)%pdg3) write (u, "(A,1x,I7,1x,A,2(1x,I7),A," // & size_pdg3 // "(1x,I7))") & " ", i, ":", vt%entry(i)%pdg1, & vt%entry(i)%pdg2, "->", vt%entry(i)%pdg3 end if end do end subroutine vertex_table_write @ %def vertex_table_write @ Initializing the vertex table: This is done in two passes. First, we scan all permutations for all vertices and count the number of entries in each bucket of the hashtable. Then, the buckets are allocated accordingly and filled. Collision resolution is done by just incrementing the hash value until an empty bucket is found. The vertex table size is fixed, since we know from the beginning the number of entries. <>= procedure :: init => vertex_table_init <>= subroutine vertex_table_init (vt, prt, vtx) class(vertex_table_t), intent(out) :: vt type(field_data_t), dimension(:), intent(in) :: prt type(vertex_t), dimension(:), intent(in) :: vtx integer :: n_vtx, vt_size, i, p1, p2, p3 integer, dimension(3) :: p n_vtx = size (vtx) vt_size = vertex_table_size (count (vtx%trilinear)) vt%mask = vt_size - 1 allocate (vt%entry (0:vt_size-1)) do i = 1, n_vtx if (vtx(i)%trilinear) then p = vtx(i)%pdg p1 = p(1); p2 = p(2) call create (hash2 (p1, p2)) if (p(2) /= p(3)) then p2 = p(3) call create (hash2 (p1, p2)) end if if (p(1) /= p(2)) then p1 = p(2); p2 = p(1) call create (hash2 (p1, p2)) if (p(1) /= p(3)) then p2 = p(3) call create (hash2 (p1, p2)) end if end if if (p(1) /= p(3)) then p1 = p(3); p2 = p(1) call create (hash2 (p1, p2)) if (p(1) /= p(2)) then p2 = p(2) call create (hash2 (p1, p2)) end if end if end if end do do i = 0, vt_size - 1 allocate (vt%entry(i)%pdg3 (vt%entry(i)%n)) end do vt%entry%n = 0 do i = 1, n_vtx if (vtx(i)%trilinear) then p = vtx(i)%pdg p1 = p(1); p2 = p(2); p3 = p(3) call register (hash2 (p1, p2)) if (p(2) /= p(3)) then p2 = p(3); p3 = p(2) call register (hash2 (p1, p2)) end if if (p(1) /= p(2)) then p1 = p(2); p2 = p(1); p3 = p(3) call register (hash2 (p1, p2)) if (p(1) /= p(3)) then p2 = p(3); p3 = p(1) call register (hash2 (p1, p2)) end if end if if (p(1) /= p(3)) then p1 = p(3); p2 = p(1); p3 = p(2) call register (hash2 (p1, p2)) if (p(1) /= p(2)) then p2 = p(2); p3 = p(1) call register (hash2 (p1, p2)) end if end if end if end do contains recursive subroutine create (hashval) integer(i32), intent(in) :: hashval integer :: h h = iand (hashval, vt%mask) if (vt%entry(h)%n == 0) then vt%entry(h)%pdg1 = p1 vt%entry(h)%pdg2 = p2 vt%entry(h)%n = 1 else if (vt%entry(h)%pdg1 == p1 .and. vt%entry(h)%pdg2 == p2) then vt%entry(h)%n = vt%entry(h)%n + 1 else vt%n_collisions = vt%n_collisions + 1 call create (hashval + 1) end if end subroutine create recursive subroutine register (hashval) integer(i32), intent(in) :: hashval integer :: h h = iand (hashval, vt%mask) if (vt%entry(h)%pdg1 == p1 .and. vt%entry(h)%pdg2 == p2) then vt%entry(h)%n = vt%entry(h)%n + 1 vt%entry(h)%pdg3(vt%entry(h)%n) = p3 else call register (hashval + 1) end if end subroutine register end subroutine vertex_table_init @ %def vertex_table_init @ Return the array of particle codes that match the given pair. <>= procedure :: match => vertex_table_match <>= subroutine vertex_table_match (vt, pdg1, pdg2, pdg3) class(vertex_table_t), intent(in) :: vt integer, intent(in) :: pdg1, pdg2 integer, dimension(:), allocatable, intent(out) :: pdg3 call match (hash2 (pdg1, pdg2)) contains recursive subroutine match (hashval) integer(i32), intent(in) :: hashval integer :: h h = iand (hashval, vt%mask) if (vt%entry(h)%n == 0) then allocate (pdg3 (0)) else if (vt%entry(h)%pdg1 == pdg1 .and. vt%entry(h)%pdg2 == pdg2) then allocate (pdg3 (size (vt%entry(h)%pdg3))) pdg3 = vt%entry(h)%pdg3 else call match (hashval + 1) end if end subroutine match end subroutine vertex_table_match @ %def vertex_table_match @ Return true if the triplet is represented as a vertex. <>= procedure :: check => vertex_table_check <>= function vertex_table_check (vt, pdg1, pdg2, pdg3) result (flag) class(vertex_table_t), intent(in) :: vt integer, intent(in) :: pdg1, pdg2, pdg3 logical :: flag flag = check (hash2 (pdg1, pdg2)) contains recursive function check (hashval) result (flag) integer(i32), intent(in) :: hashval integer :: h logical :: flag h = iand (hashval, vt%mask) if (vt%entry(h)%n == 0) then flag = .false. else if (vt%entry(h)%pdg1 == pdg1 .and. vt%entry(h)%pdg2 == pdg2) then flag = any (vt%entry(h)%pdg3 == pdg3) else flag = check (hashval + 1) end if end function check end function vertex_table_check @ %def vertex_table_check @ \subsection{Model Data Record} This type collects the model data as defined above. We deliberately implement the parameter arrays as pointer arrays. We thus avoid keeping track of TARGET attributes. The [[scheme]] identifier provides meta information. It doesn't give the client code an extra parameter, but it tells something about the interpretation of the parameters. If the scheme ID is left as default (zero), it is ignored. <>= public :: model_data_t <>= type :: model_data_t private type(string_t) :: name integer :: scheme = 0 type(modelpar_real_t), dimension(:), pointer :: par_real => null () type(modelpar_complex_t), dimension(:), pointer :: par_complex => null () type(field_data_t), dimension(:), allocatable :: field type(vertex_t), dimension(:), allocatable :: vtx type(vertex_table_t) :: vt contains <> end type model_data_t @ %def model_data_t @ Finalizer, deallocate pointer arrays. <>= procedure :: final => model_data_final <>= subroutine model_data_final (model) class(model_data_t), intent(inout) :: model if (associated (model%par_real)) then deallocate (model%par_real) end if if (associated (model%par_complex)) then deallocate (model%par_complex) end if end subroutine model_data_final @ %def model_data_final @ Output. The signature matches the signature of the high-level [[model_write]] procedure, so some of the options don't actually apply. <>= procedure :: write => model_data_write <>= subroutine model_data_write (model, unit, verbose, & show_md5sum, show_variables, show_parameters, & show_particles, show_vertices, show_scheme) class(model_data_t), intent(in) :: model integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical, intent(in), optional :: show_md5sum logical, intent(in), optional :: show_variables logical, intent(in), optional :: show_parameters logical, intent(in), optional :: show_particles logical, intent(in), optional :: show_vertices logical, intent(in), optional :: show_scheme logical :: show_sch, show_par, show_prt, show_vtx integer :: u, i u = given_output_unit (unit) show_sch = .false.; if (present (show_scheme)) & show_sch = show_scheme show_par = .true.; if (present (show_parameters)) & show_par = show_parameters show_prt = .true.; if (present (show_particles)) & show_prt = show_particles show_vtx = .true.; if (present (show_vertices)) & show_vtx = show_vertices if (show_sch) then write (u, "(3x,A,1X,I0)") "scheme =", model%scheme end if if (show_par) then do i = 1, size (model%par_real) call model%par_real(i)%write (u) write (u, "(A)") end do do i = 1, size (model%par_complex) call model%par_complex(i)%write (u) write (u, "(A)") end do end if if (show_prt) then write (u, "(A)") call model%write_fields (u) end if if (show_vtx) then write (u, "(A)") call model%write_vertices (u, verbose) end if end subroutine model_data_write @ %def model_data_write @ Initialize, allocating pointer arrays. The second version makes a deep copy. <>= generic :: init => model_data_init procedure, private :: model_data_init <>= subroutine model_data_init (model, name, & n_par_real, n_par_complex, n_field, n_vtx) class(model_data_t), intent(out) :: model type(string_t), intent(in) :: name integer, intent(in) :: n_par_real, n_par_complex integer, intent(in) :: n_field integer, intent(in) :: n_vtx model%name = name allocate (model%par_real (n_par_real)) allocate (model%par_complex (n_par_complex)) allocate (model%field (n_field)) allocate (model%vtx (n_vtx)) end subroutine model_data_init @ %def model_data_init @ Set the scheme ID. <>= procedure :: set_scheme_num => model_data_set_scheme_num <>= subroutine model_data_set_scheme_num (model, scheme) class(model_data_t), intent(inout) :: model integer, intent(in) :: scheme model%scheme = scheme end subroutine model_data_set_scheme_num @ %def model_data_set_scheme_num @ Complete model data initialization. <>= procedure :: freeze_fields => model_data_freeze_fields <>= subroutine model_data_freeze_fields (model) class(model_data_t), intent(inout) :: model call model%field%freeze () end subroutine model_data_freeze_fields @ %def model_data_freeze @ Deep copy. The new model should already be initialized, so we do not allocate memory. <>= procedure :: copy_from => model_data_copy <>= subroutine model_data_copy (model, src) class(model_data_t), intent(inout), target :: model class(model_data_t), intent(in), target :: src class(modelpar_data_t), pointer :: data, src_data integer :: i model%scheme = src%scheme model%par_real = src%par_real model%par_complex = src%par_complex do i = 1, size (src%field) associate (field => model%field(i), src_field => src%field(i)) call field%init (src_field%get_longname (), src_field%get_pdg ()) call field%copy_from (src_field) src_data => src_field%mass_data if (associated (src_data)) then data => model%get_par_data_ptr (src_data%get_name ()) call field%set (mass_data = data) end if src_data => src_field%width_data if (associated (src_data)) then data => model%get_par_data_ptr (src_data%get_name ()) call field%set (width_data = data) end if call field%set_multiplicity () end associate end do do i = 1, size (src%vtx) call model%vtx(i)%copy_from (src%vtx(i), model) end do call model%freeze_vertices () end subroutine model_data_copy @ %def model_data_copy @ Return the model name and numeric scheme. <>= procedure :: get_name => model_data_get_name procedure :: get_scheme_num => model_data_get_scheme_num <>= function model_data_get_name (model) result (name) class(model_data_t), intent(in) :: model type(string_t) :: name name = model%name end function model_data_get_name function model_data_get_scheme_num (model) result (scheme) class(model_data_t), intent(in) :: model integer :: scheme scheme = model%scheme end function model_data_get_scheme_num @ %def model_data_get_name @ %def model_data_get_scheme @ Retrieve a MD5 sum for the current model parameter values and decay/polarization settings. This is done by writing them to a temporary file, using a standard format. If the model scheme is nonzero, it is also written. <>= procedure :: get_parameters_md5sum => model_data_get_parameters_md5sum <>= function model_data_get_parameters_md5sum (model) result (par_md5sum) character(32) :: par_md5sum class(model_data_t), intent(in) :: model real(default), dimension(:), allocatable :: par type(field_data_t), pointer :: field integer :: unit, i allocate (par (model%get_n_real ())) call model%real_parameters_to_array (par) unit = free_unit () open (unit, status="scratch", action="readwrite") if (model%scheme /= 0) write (unit, "(I0)") model%scheme write (unit, "(" // FMT_19 // ")") par do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (.not. field%is_stable (.false.) .or. .not. field%is_stable (.true.) & .or. field%is_polarized (.false.) .or. field%is_polarized (.true.))& then write (unit, "(3x,A)") char (field%get_longname ()) call field%write_decays (unit) end if end do rewind (unit) par_md5sum = md5sum (unit) close (unit) end function model_data_get_parameters_md5sum @ %def model_get_parameters_md5sum @ Return the MD5 sum. This is a placeholder, to be overwritten for the complete model definition. <>= procedure :: get_md5sum => model_data_get_md5sum <>= function model_data_get_md5sum (model) result (md5sum) class(model_data_t), intent(in) :: model character(32) :: md5sum md5sum = model%get_parameters_md5sum () end function model_data_get_md5sum @ %def model_data_get_md5sum @ Initialize a real or complex parameter. <>= generic :: init_par => model_data_init_par_real, model_data_init_par_complex procedure, private :: model_data_init_par_real procedure, private :: model_data_init_par_complex <>= subroutine model_data_init_par_real (model, i, name, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: i type(string_t), intent(in) :: name real(default), intent(in) :: value call model%par_real(i)%init (name, value) end subroutine model_data_init_par_real subroutine model_data_init_par_complex (model, i, name, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: i type(string_t), intent(in) :: name complex(default), intent(in) :: value call model%par_complex(i)%init (name, value) end subroutine model_data_init_par_complex @ %def model_data_init_par_real model_data_init_par_complex @ After initialization, return size of parameter array. <>= procedure :: get_n_real => model_data_get_n_real procedure :: get_n_complex => model_data_get_n_complex <>= function model_data_get_n_real (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%par_real) end function model_data_get_n_real function model_data_get_n_complex (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%par_complex) end function model_data_get_n_complex @ %def model_data_get_n_real @ %def model_data_get_n_complex @ After initialization, extract the whole parameter array. <>= procedure :: real_parameters_to_array & => model_data_real_par_to_array procedure :: complex_parameters_to_array & => model_data_complex_par_to_array <>= subroutine model_data_real_par_to_array (model, array) class(model_data_t), intent(in) :: model real(default), dimension(:), intent(inout) :: array array = model%par_real%get_real () end subroutine model_data_real_par_to_array subroutine model_data_complex_par_to_array (model, array) class(model_data_t), intent(in) :: model complex(default), dimension(:), intent(inout) :: array array = model%par_complex%get_complex () end subroutine model_data_complex_par_to_array @ %def model_data_real_par_to_array @ %def model_data_complex_par_to_array @ After initialization, set the whole parameter array. <>= procedure :: real_parameters_from_array & => model_data_real_par_from_array procedure :: complex_parameters_from_array & => model_data_complex_par_from_array <>= subroutine model_data_real_par_from_array (model, array) class(model_data_t), intent(inout) :: model real(default), dimension(:), intent(in) :: array model%par_real = array end subroutine model_data_real_par_from_array subroutine model_data_complex_par_from_array (model, array) class(model_data_t), intent(inout) :: model complex(default), dimension(:), intent(in) :: array model%par_complex = array end subroutine model_data_complex_par_from_array @ %def model_data_real_par_from_array @ %def model_data_complex_par_from_array @ Analogous, for a C parameter array. <>= procedure :: real_parameters_to_c_array & => model_data_real_par_to_c_array <>= subroutine model_data_real_par_to_c_array (model, array) class(model_data_t), intent(in) :: model real(c_default_float), dimension(:), intent(inout) :: array array = model%par_real%get_real () end subroutine model_data_real_par_to_c_array @ %def model_data_real_par_to_c_array @ After initialization, set the whole parameter array. <>= procedure :: real_parameters_from_c_array & => model_data_real_par_from_c_array <>= subroutine model_data_real_par_from_c_array (model, array) class(model_data_t), intent(inout) :: model real(c_default_float), dimension(:), intent(in) :: array model%par_real = real (array, default) end subroutine model_data_real_par_from_c_array @ %def model_data_real_par_from_c_array @ After initialization, get pointer to a real or complex parameter, directly by index. <>= procedure :: get_par_real_ptr => model_data_get_par_real_ptr_index procedure :: get_par_complex_ptr => model_data_get_par_complex_ptr_index <>= function model_data_get_par_real_ptr_index (model, i) result (ptr) class(model_data_t), intent(inout) :: model integer, intent(in) :: i class(modelpar_data_t), pointer :: ptr ptr => model%par_real(i) end function model_data_get_par_real_ptr_index function model_data_get_par_complex_ptr_index (model, i) result (ptr) class(model_data_t), intent(inout) :: model integer, intent(in) :: i class(modelpar_data_t), pointer :: ptr ptr => model%par_complex(i) end function model_data_get_par_complex_ptr_index @ %def model_data_get_par_real_ptr model_data_get_par_complex_ptr @ After initialization, get pointer to a parameter by name. <>= procedure :: get_par_data_ptr => model_data_get_par_data_ptr_name <>= function model_data_get_par_data_ptr_name (model, name) result (ptr) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: ptr integer :: i do i = 1, size (model%par_real) if (model%par_real(i)%name == name) then ptr => model%par_real(i) return end if end do do i = 1, size (model%par_complex) if (model%par_complex(i)%name == name) then ptr => model%par_complex(i) return end if end do ptr => null () end function model_data_get_par_data_ptr_name @ %def model_data_get_par_data_ptr @ Return the value by name. Again, type conversion is allowed. <>= procedure :: get_real => model_data_get_par_real_value procedure :: get_complex => model_data_get_par_complex_value <>= function model_data_get_par_real_value (model, name) result (value) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: par real(default) :: value par => model%get_par_data_ptr (name) value = par%get_real () end function model_data_get_par_real_value function model_data_get_par_complex_value (model, name) result (value) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: par complex(default) :: value par => model%get_par_data_ptr (name) value = par%get_complex () end function model_data_get_par_complex_value @ %def model_data_get_real @ %def model_data_get_complex @ Modify a real or complex parameter. <>= generic :: set_par => model_data_set_par_real, model_data_set_par_complex procedure, private :: model_data_set_par_real procedure, private :: model_data_set_par_complex <>= subroutine model_data_set_par_real (model, name, value) class(model_data_t), intent(inout) :: model type(string_t), intent(in) :: name real(default), intent(in) :: value class(modelpar_data_t), pointer :: par par => model%get_par_data_ptr (name) par = value end subroutine model_data_set_par_real subroutine model_data_set_par_complex (model, name, value) class(model_data_t), intent(inout) :: model type(string_t), intent(in) :: name complex(default), intent(in) :: value class(modelpar_data_t), pointer :: par par => model%get_par_data_ptr (name) par = value end subroutine model_data_set_par_complex @ %def model_data_set_par_real model_data_set_par_complex @ List all fields in the model. <>= procedure :: write_fields => model_data_write_fields <>= subroutine model_data_write_fields (model, unit) class(model_data_t), intent(in) :: model integer, intent(in), optional :: unit integer :: i do i = 1, size (model%field) call model%field(i)%write (unit) end do end subroutine model_data_write_fields @ %def model_data_write_fields @ After initialization, return number of fields (particles): <>= procedure :: get_n_field => model_data_get_n_field <>= function model_data_get_n_field (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%field) end function model_data_get_n_field @ %def model_data_get_n_field @ Return the PDG code of a field. The field is identified by name or by index. If the field is not found, return zero. <>= generic :: get_pdg => & model_data_get_field_pdg_index, & model_data_get_field_pdg_name procedure, private :: model_data_get_field_pdg_index procedure, private :: model_data_get_field_pdg_name <>= function model_data_get_field_pdg_index (model, i) result (pdg) class(model_data_t), intent(in) :: model integer, intent(in) :: i integer :: pdg pdg = model%field(i)%get_pdg () end function model_data_get_field_pdg_index function model_data_get_field_pdg_name (model, name, check) result (pdg) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name logical, intent(in), optional :: check integer :: pdg integer :: i do i = 1, size (model%field) associate (field => model%field(i)) if (field%matches_name (name, .false.)) then pdg = field%get_pdg () return else if (field%matches_name (name, .true.)) then pdg = - field%get_pdg () return end if end associate end do pdg = 0 call model%field_error (check, name) end function model_data_get_field_pdg_name @ %def model_data_get_field_pdg @ Return an array of all PDG codes, including antiparticles. The antiparticle are sorted after all particles. <>= procedure :: get_all_pdg => model_data_get_all_pdg <>= subroutine model_data_get_all_pdg (model, pdg) class(model_data_t), intent(in) :: model integer, dimension(:), allocatable, intent(inout) :: pdg integer :: n0, n1, i, k n0 = size (model%field) n1 = n0 + count (model%field%has_antiparticle ()) allocate (pdg (n1)) pdg(1:n0) = model%field%get_pdg () k = n0 do i = 1, size (model%field) associate (field => model%field(i)) if (field%has_antiparticle ()) then k = k + 1 pdg(k) = - field%get_pdg () end if end associate end do end subroutine model_data_get_all_pdg @ %def model_data_get_all_pdg @ Return pointer to the field array. <>= procedure :: get_field_array_ptr => model_data_get_field_array_ptr <>= function model_data_get_field_array_ptr (model) result (ptr) class(model_data_t), intent(in), target :: model type(field_data_t), dimension(:), pointer :: ptr ptr => model%field end function model_data_get_field_array_ptr @ %def model_data_get_field_array_ptr @ Return pointer to a field. The identifier should be the unique long name, the PDG code, or the index. We can issue an error message, if the [[check]] flag is set. We never return an error if the PDG code is zero, this yields just a null pointer. <>= generic :: get_field_ptr => & model_data_get_field_ptr_name, & model_data_get_field_ptr_pdg procedure, private :: model_data_get_field_ptr_name procedure, private :: model_data_get_field_ptr_pdg procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index <>= function model_data_get_field_ptr_name (model, name, check) result (ptr) class(model_data_t), intent(in), target :: model type(string_t), intent(in) :: name logical, intent(in), optional :: check type(field_data_t), pointer :: ptr integer :: i do i = 1, size (model%field) if (model%field(i)%matches_name (name, .false.)) then ptr => model%field(i) return else if (model%field(i)%matches_name (name, .true.)) then ptr => model%field(i) return end if end do ptr => null () call model%field_error (check, name) end function model_data_get_field_ptr_name function model_data_get_field_ptr_pdg (model, pdg, check) result (ptr) class(model_data_t), intent(in), target :: model integer, intent(in) :: pdg logical, intent(in), optional :: check type(field_data_t), pointer :: ptr integer :: i, pdg_abs if (pdg == 0) then ptr => null () return end if pdg_abs = abs (pdg) do i = 1, size (model%field) - if (model%field(i)%get_pdg () == pdg_abs) then + if (abs(model%field(i)%get_pdg ()) == pdg_abs) then ptr => model%field(i) return end if end do ptr => null () call model%field_error (check, pdg=pdg) end function model_data_get_field_ptr_pdg function model_data_get_field_ptr_index (model, i) result (ptr) class(model_data_t), intent(in), target :: model integer, intent(in) :: i type(field_data_t), pointer :: ptr ptr => model%field(i) end function model_data_get_field_ptr_index @ %def model_data_get_field_ptr @ Don't assign a pointer, just check. <>= procedure :: test_field => model_data_test_field_pdg <>= function model_data_test_field_pdg (model, pdg, check) result (exist) class(model_data_t), intent(in), target :: model integer, intent(in) :: pdg logical, intent(in), optional :: check logical :: exist exist = associated (model%get_field_ptr (pdg, check)) end function model_data_test_field_pdg @ %def model_data_test_field_pdg @ Error message, if [[check]] is set. <>= procedure :: field_error => model_data_field_error <>= subroutine model_data_field_error (model, check, name, pdg) class(model_data_t), intent(in) :: model logical, intent(in), optional :: check type(string_t), intent(in), optional :: name integer, intent(in), optional :: pdg if (present (check)) then if (check) then if (present (name)) then write (msg_buffer, "(A,1x,A,1x,A,1x,A)") & "No particle with name", char (name), & "is contained in model", char (model%name) else if (present (pdg)) then write (msg_buffer, "(A,1x,I0,1x,A,1x,A)") & "No particle with PDG code", pdg, & "is contained in model", char (model%name) else write (msg_buffer, "(A,1x,A,1x,A)") & "Particle missing", & "in model", char (model%name) end if call msg_fatal () end if end if end subroutine model_data_field_error @ %def model_data_field_error @ Assign mass and width value, which are associated via pointer. Identify the particle via pdg. <>= procedure :: set_field_mass => model_data_set_field_mass_pdg procedure :: set_field_width => model_data_set_field_width_pdg <>= subroutine model_data_set_field_mass_pdg (model, pdg, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: pdg real(default), intent(in) :: value type(field_data_t), pointer :: field field => model%get_field_ptr (pdg, check = .true.) call field%set_mass (value) end subroutine model_data_set_field_mass_pdg subroutine model_data_set_field_width_pdg (model, pdg, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: pdg real(default), intent(in) :: value type(field_data_t), pointer :: field field => model%get_field_ptr (pdg, check = .true.) call field%set_width (value) end subroutine model_data_set_field_width_pdg @ %def model_data_set_field_mass @ %def model_data_set_field_width @ Mark a particle as unstable and provide a list of names for its decay processes. In contrast with the previous subroutine which is for internal use, we address the particle by its PDG code. If the index is negative, we address the antiparticle. <>= procedure :: set_unstable => model_data_set_unstable procedure :: set_stable => model_data_set_stable <>= subroutine model_data_set_unstable & (model, pdg, decay, isotropic, diagonal, decay_helicity) class(model_data_t), intent(inout), target :: model integer, intent(in) :: pdg type(string_t), dimension(:), intent(in) :: decay logical, intent(in), optional :: isotropic, diagonal integer, intent(in), optional :: decay_helicity type(field_data_t), pointer :: field field => model%get_field_ptr (pdg) if (pdg > 0) then call field%set ( & p_is_stable = .false., p_decay = decay, & p_decays_isotropically = isotropic, & p_decays_diagonal = diagonal, & p_decay_helicity = decay_helicity) else call field%set ( & a_is_stable = .false., a_decay = decay, & a_decays_isotropically = isotropic, & a_decays_diagonal = diagonal, & a_decay_helicity = decay_helicity) end if end subroutine model_data_set_unstable subroutine model_data_set_stable (model, pdg) class(model_data_t), intent(inout), target :: model integer, intent(in) :: pdg type(field_data_t), pointer :: field field => model%get_field_ptr (pdg) if (pdg > 0) then call field%set (p_is_stable = .true.) else call field%set (a_is_stable = .true.) end if end subroutine model_data_set_stable @ %def model_data_set_unstable @ %def model_data_set_stable @ Mark a particle as polarized. <>= procedure :: set_polarized => model_data_set_polarized procedure :: set_unpolarized => model_data_set_unpolarized <>= subroutine model_data_set_polarized (model, pdg) class(model_data_t), intent(inout), target :: model integer, intent(in) :: pdg type(field_data_t), pointer :: field field => model%get_field_ptr (pdg) if (pdg > 0) then call field%set (p_polarized = .true.) else call field%set (a_polarized = .true.) end if end subroutine model_data_set_polarized subroutine model_data_set_unpolarized (model, pdg) class(model_data_t), intent(inout), target :: model integer, intent(in) :: pdg type(field_data_t), pointer :: field field => model%get_field_ptr (pdg) if (pdg > 0) then call field%set (p_polarized = .false.) else call field%set (a_polarized = .false.) end if end subroutine model_data_set_unpolarized @ %def model_data_set_polarized @ %def model_data_set_unpolarized @ Revert all polarized (unstable) particles to unpolarized (stable) status, respectively. <>= procedure :: clear_unstable => model_clear_unstable procedure :: clear_polarized => model_clear_polarized <>= subroutine model_clear_unstable (model) class(model_data_t), intent(inout), target :: model integer :: i type(field_data_t), pointer :: field do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) call field%set (p_is_stable = .true.) if (field%has_antiparticle ()) then call field%set (a_is_stable = .true.) end if end do end subroutine model_clear_unstable subroutine model_clear_polarized (model) class(model_data_t), intent(inout), target :: model integer :: i type(field_data_t), pointer :: field do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) call field%set (p_polarized = .false.) if (field%has_antiparticle ()) then call field%set (a_polarized = .false.) end if end do end subroutine model_clear_polarized @ %def model_clear_unstable @ %def model_clear_polarized @ List all vertices, optionally also the hash table. <>= procedure :: write_vertices => model_data_write_vertices <>= subroutine model_data_write_vertices (model, unit, verbose) class(model_data_t), intent(in) :: model integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: i, u u = given_output_unit (unit) do i = 1, size (model%vtx) call vertex_write (model%vtx(i), unit) end do if (present (verbose)) then if (verbose) then write (u, *) call vertex_table_write (model%vt, unit) end if end if end subroutine model_data_write_vertices @ %def model_data_write_vertices @ Vertex definition. <>= generic :: set_vertex => & model_data_set_vertex_pdg, model_data_set_vertex_names procedure, private :: model_data_set_vertex_pdg procedure, private :: model_data_set_vertex_names <>= subroutine model_data_set_vertex_pdg (model, i, pdg) class(model_data_t), intent(inout), target :: model integer, intent(in) :: i integer, dimension(:), intent(in) :: pdg call vertex_init (model%vtx(i), pdg, model) end subroutine model_data_set_vertex_pdg subroutine model_data_set_vertex_names (model, i, name) class(model_data_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), dimension(:), intent(in) :: name integer, dimension(size(name)) :: pdg integer :: j do j = 1, size (name) pdg(j) = model%get_pdg (name(j)) end do call model%set_vertex (i, pdg) end subroutine model_data_set_vertex_names @ %def model_data_set_vertex @ Finalize vertex definition: set up the hash table. <>= procedure :: freeze_vertices => model_data_freeze_vertices <>= subroutine model_data_freeze_vertices (model) class(model_data_t), intent(inout) :: model call model%vt%init (model%field, model%vtx) end subroutine model_data_freeze_vertices @ %def model_data_freeze_vertices @ Number of vertices in model <>= procedure :: get_n_vtx => model_data_get_n_vtx <>= function model_data_get_n_vtx (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%vtx) end function model_data_get_n_vtx @ %def model_data_get_n_vtx @ Lookup functions <>= procedure :: match_vertex => model_data_match_vertex <>= subroutine model_data_match_vertex (model, pdg1, pdg2, pdg3) class(model_data_t), intent(in) :: model integer, intent(in) :: pdg1, pdg2 integer, dimension(:), allocatable, intent(out) :: pdg3 call model%vt%match (pdg1, pdg2, pdg3) end subroutine model_data_match_vertex @ %def model_data_match_vertex <>= procedure :: check_vertex => model_data_check_vertex <>= function model_data_check_vertex (model, pdg1, pdg2, pdg3) result (flag) logical :: flag class(model_data_t), intent(in) :: model integer, intent(in) :: pdg1, pdg2, pdg3 flag = model%vt%check (pdg1, pdg2, pdg3) end function model_data_check_vertex @ %def model_data_check_vertex @ \subsection{Toy Models} This is a stripped-down version of the (already trivial) model 'Test'. <>= procedure :: init_test => model_data_init_test <>= subroutine model_data_init_test (model) class(model_data_t), intent(out) :: model type(field_data_t), pointer :: field integer, parameter :: n_real = 4 integer, parameter :: n_field = 2 integer, parameter :: n_vertex = 2 integer :: i call model%init (var_str ("Test"), & n_real, 0, n_field, n_vertex) i = 0 i = i + 1 call model%init_par (i, var_str ("gy"), 1._default) i = i + 1 call model%init_par (i, var_str ("ms"), 125._default) i = i + 1 call model%init_par (i, var_str ("ff"), 1.5_default) i = i + 1 call model%init_par (i, var_str ("mf"), 1.5_default * 125._default) i = 0 i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("SCALAR"), 25) call field%set (spin_type=1) call field%set (mass_data=model%get_par_real_ptr (2)) call field%set (name = [var_str ("s")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("FERMION"), 6) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (4)) call field%set (name = [var_str ("f")], anti = [var_str ("fbar")]) call model%freeze_fields () i = 0 i = i + 1 call model%set_vertex (i, [var_str ("fbar"), var_str ("f"), var_str ("s")]) i = i + 1 call model%set_vertex (i, [var_str ("s"), var_str ("s"), var_str ("s")]) call model%freeze_vertices () end subroutine model_data_init_test @ %def model_data_init_test @ This procedure prepares a subset of QED for testing purposes. <>= procedure :: init_qed_test => model_data_init_qed_test <>= subroutine model_data_init_qed_test (model) class(model_data_t), intent(out) :: model type(field_data_t), pointer :: field integer, parameter :: n_real = 1 integer, parameter :: n_field = 2 integer :: i call model%init (var_str ("QED_test"), & n_real, 0, n_field, 0) i = 0 i = i + 1 call model%init_par (i, var_str ("me"), 0.000510997_default) i = 0 i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("E_LEPTON"), 11) call field%set (spin_type=2, charge_type=-4) call field%set (mass_data=model%get_par_real_ptr (1)) call field%set (name = [var_str ("e-")], anti = [var_str ("e+")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("PHOTON"), 22) call field%set (spin_type=3) call field%set (name = [var_str ("A")]) call model%freeze_fields () call model%freeze_vertices () end subroutine model_data_init_qed_test @ %def model_data_init_qed_test @ This procedure prepares a subset of the Standard Model for testing purposes. We can thus avoid dependencies on model I/O, which is not defined here. <>= procedure :: init_sm_test => model_data_init_sm_test <>= subroutine model_data_init_sm_test (model) class(model_data_t), intent(out) :: model type(field_data_t), pointer :: field integer, parameter :: n_real = 11 integer, parameter :: n_field = 19 integer, parameter :: n_vtx = 9 integer :: i call model%init (var_str ("SM_test"), & n_real, 0, n_field, n_vtx) i = 0 i = i + 1 call model%init_par (i, var_str ("mZ"), 91.1882_default) i = i + 1 call model%init_par (i, var_str ("mW"), 80.419_default) i = i + 1 call model%init_par (i, var_str ("me"), 0.000510997_default) i = i + 1 call model%init_par (i, var_str ("mmu"), 0.105658389_default) i = i + 1 call model%init_par (i, var_str ("mb"), 4.2_default) i = i + 1 call model%init_par (i, var_str ("mtop"), 173.1_default) i = i + 1 call model%init_par (i, var_str ("wZ"), 2.443_default) i = i + 1 call model%init_par (i, var_str ("wW"), 2.049_default) i = i + 1 call model%init_par (i, var_str ("ee"), 0.3079561542961_default) i = i + 1 call model%init_par (i, var_str ("cw"), 8.819013863636E-01_default) i = i + 1 call model%init_par (i, var_str ("sw"), 4.714339240339E-01_default) i = 0 i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("D_QUARK"), 1) call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) call field%set (name = [var_str ("d")], anti = [var_str ("dbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("U_QUARK"), 2) call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) call field%set (name = [var_str ("u")], anti = [var_str ("ubar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("S_QUARK"), 3) call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) call field%set (name = [var_str ("s")], anti = [var_str ("sbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("C_QUARK"), 4) call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) call field%set (name = [var_str ("c")], anti = [var_str ("cbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("B_QUARK"), 5) call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) call field%set (mass_data=model%get_par_real_ptr (5)) call field%set (name = [var_str ("b")], anti = [var_str ("bbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("T_QUARK"), 6) call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) call field%set (mass_data=model%get_par_real_ptr (6)) call field%set (name = [var_str ("t")], anti = [var_str ("tbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("E_LEPTON"), 11) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (3)) call field%set (name = [var_str ("e-")], anti = [var_str ("e+")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("E_NEUTRINO"), 12) call field%set (spin_type=2, is_left_handed=.true.) call field%set (name = [var_str ("nue")], anti = [var_str ("nuebar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("MU_LEPTON"), 13) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (4)) call field%set (name = [var_str ("mu-")], anti = [var_str ("mu+")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("MU_NEUTRINO"), 14) call field%set (spin_type=2, is_left_handed=.true.) call field%set (name = [var_str ("numu")], anti = [var_str ("numubar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("GLUON"), 21) call field%set (spin_type=3, color_type=8) call field%set (name = [var_str ("gl")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("PHOTON"), 22) call field%set (spin_type=3) call field%set (name = [var_str ("A")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("Z_BOSON"), 23) call field%set (spin_type=3) call field%set (mass_data=model%get_par_real_ptr (1)) call field%set (width_data=model%get_par_real_ptr (7)) call field%set (name = [var_str ("Z")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("W_BOSON"), 24) call field%set (spin_type=3) call field%set (mass_data=model%get_par_real_ptr (2)) call field%set (width_data=model%get_par_real_ptr (8)) call field%set (name = [var_str ("W+")], anti = [var_str ("W-")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HIGGS"), 25) call field%set (spin_type=1) ! call field%set (mass_data=model%get_par_real_ptr (2)) ! call field%set (width_data=model%get_par_real_ptr (8)) call field%set (name = [var_str ("H")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("PROTON"), 2212) call field%set (spin_type=2) call field%set (name = [var_str ("p")], anti = [var_str ("pbar")]) ! call field%set (mass_data=model%get_par_real_ptr (12)) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HADRON_REMNANT_SINGLET"), 91) call field%set (color_type=1) call field%set (name = [var_str ("hr1")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HADRON_REMNANT_TRIPLET"), 92) call field%set (color_type=3) call field%set (name = [var_str ("hr3")], anti = [var_str ("hr3bar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HADRON_REMNANT_OCTET"), 93) call field%set (color_type=8) call field%set (name = [var_str ("hr8")]) call model%freeze_fields () i = 0 i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("d"), var_str ("W+")]) i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("u"), var_str ("W-")]) call model%freeze_vertices () end subroutine model_data_init_sm_test @ %def model_data_init_sm_test @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Model Testbed} The standard way of defining a model uses concrete variables and expressions to interpret the model file. Some of this is not available at the point of use. This is no problem for the \whizard\ program as a whole, but unit tests are kept local to their respective module and don't access all definitions. Instead, we introduce a separate module that provides hooks, one for initializing a model and one for finalizing a model. The main program can assign real routines to the hooks (procedure pointers of abstract type) before unit tests are called. The unit tests can call the abstract routines without knowing about their implementation. <<[[model_testbed.f90]]>>= <> module model_testbed <> use model_data use var_base <> <> <> <> end module model_testbed @ %def model_testbed @ \subsection{Abstract Model Handlers} Both routines take a polymorphic model (data) target, which is not allocated/deallocated inside the subroutine. The model constructor [[prepare_model]] requires the model name as input. It can, optionally, return a link to the variable list of the model. <>= public :: prepare_model public :: cleanup_model <>= procedure (prepare_model_proc), pointer :: prepare_model => null () procedure (cleanup_model_proc), pointer :: cleanup_model => null () <>= abstract interface subroutine prepare_model_proc (model, name, vars) import class(model_data_t), intent(inout), pointer :: model type(string_t), intent(in) :: name class(vars_t), pointer, intent(out), optional :: vars end subroutine prepare_model_proc end interface abstract interface subroutine cleanup_model_proc (model) import class(model_data_t), intent(inout), target :: model end subroutine cleanup_model_proc end interface @ %def prepare_model @ %def cleanup_model @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Helicities} This module defines types and tools for dealing with helicity information. <<[[helicities.f90]]>>= <> module helicities use io_units <> <> <> <> contains <> end module helicities @ %def helicities @ \subsection{Helicity types} Helicities may be defined or undefined, corresponding to a polarized or unpolarized state. Each helicity is actually a pair of helicities, corresponding to an entry in the spin density matrix. Obviously, diagonal entries are distinguished. <>= public :: helicity_t <>= type :: helicity_t private logical :: defined = .false. integer :: h1, h2 contains <> end type helicity_t @ %def helicity_t @ Constructor functions, for convenience: <>= public :: helicity <>= interface helicity module procedure helicity0, helicity1, helicity2 end interface helicity <>= pure function helicity0 () result (hel) type(helicity_t) :: hel end function helicity0 elemental function helicity1 (h) result (hel) type(helicity_t) :: hel integer, intent(in) :: h call hel%init (h) end function helicity1 elemental function helicity2 (h2, h1) result (hel) type(helicity_t) :: hel integer, intent(in) :: h1, h2 call hel%init (h2, h1) end function helicity2 @ %def helicity @ Initializers. Note: conceptually, the argument to initializers should be INTENT(OUT). However, Interp.\ F08/0033 prohibited this. The reason is that, in principle, the call could result in the execution of an impure finalizer for a type extension of [[hel]] (ugh). <>= generic :: init => helicity_init_empty, helicity_init_same, helicity_init_different procedure, private :: helicity_init_empty procedure, private :: helicity_init_same procedure, private :: helicity_init_different <>= elemental subroutine helicity_init_empty (hel) class(helicity_t), intent(inout) :: hel hel%defined = .false. end subroutine helicity_init_empty elemental subroutine helicity_init_same (hel, h) class(helicity_t), intent(inout) :: hel integer, intent(in) :: h hel%defined = .true. hel%h1 = h hel%h2 = h end subroutine helicity_init_same elemental subroutine helicity_init_different (hel, h2, h1) class(helicity_t), intent(inout) :: hel integer, intent(in) :: h1, h2 hel%defined = .true. hel%h2 = h2 hel%h1 = h1 end subroutine helicity_init_different @ %def helicity_init @ Undefine: <>= procedure :: undefine => helicity_undefine <>= elemental subroutine helicity_undefine (hel) class(helicity_t), intent(inout) :: hel hel%defined = .false. end subroutine helicity_undefine @ %def helicity_undefine @ Diagonalize by removing the second entry (use with care!) <>= procedure :: diagonalize => helicity_diagonalize <>= elemental subroutine helicity_diagonalize (hel) class(helicity_t), intent(inout) :: hel hel%h2 = hel%h1 end subroutine helicity_diagonalize @ %def helicity_diagonalize @ Flip helicity indices by sign. <>= procedure :: flip => helicity_flip <>= elemental subroutine helicity_flip (hel) class(helicity_t), intent(inout) :: hel hel%h1 = - hel%h1 hel%h2 = - hel%h2 end subroutine helicity_flip @ %def helicity_flip @ <>= procedure :: get_indices => helicity_get_indices <>= subroutine helicity_get_indices (hel, h1, h2) class(helicity_t), intent(in) :: hel integer, intent(out) :: h1, h2 h1 = hel%h1; h2 = hel%h2 end subroutine helicity_get_indices @ %def helicity_get_indices @ Output (no linebreak). No output if undefined. <>= procedure :: write => helicity_write <>= subroutine helicity_write (hel, unit) class(helicity_t), intent(in) :: hel integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (hel%defined) then write (u, "(A)", advance="no") "h(" write (u, "(I0)", advance="no") hel%h1 if (hel%h1 /= hel%h2) then write (u, "(A)", advance="no") "|" write (u, "(I0)", advance="no") hel%h2 end if write (u, "(A)", advance="no") ")" end if end subroutine helicity_write @ %def helicity_write @ Binary I/O. Write contents only if defined. <>= procedure :: write_raw => helicity_write_raw procedure :: read_raw => helicity_read_raw <>= subroutine helicity_write_raw (hel, u) class(helicity_t), intent(in) :: hel integer, intent(in) :: u write (u) hel%defined if (hel%defined) then write (u) hel%h1, hel%h2 end if end subroutine helicity_write_raw subroutine helicity_read_raw (hel, u, iostat) class(helicity_t), intent(out) :: hel integer, intent(in) :: u integer, intent(out), optional :: iostat read (u, iostat=iostat) hel%defined if (hel%defined) then read (u, iostat=iostat) hel%h1, hel%h2 end if end subroutine helicity_read_raw @ %def helicity_write_raw helicity_read_raw @ \subsection{Predicates} Check if the helicity is defined: <>= procedure :: is_defined => helicity_is_defined <>= elemental function helicity_is_defined (hel) result (defined) logical :: defined class(helicity_t), intent(in) :: hel defined = hel%defined end function helicity_is_defined @ %def helicity_is_defined @ Return true if the two helicities are equal or the particle is unpolarized: <>= procedure :: is_diagonal => helicity_is_diagonal <>= elemental function helicity_is_diagonal (hel) result (diagonal) logical :: diagonal class(helicity_t), intent(in) :: hel if (hel%defined) then diagonal = hel%h1 == hel%h2 else diagonal = .true. end if end function helicity_is_diagonal @ %def helicity_is_diagonal @ \subsection{Accessing contents} This returns a two-element array and thus cannot be elemental. The result is unpredictable if the helicity is undefined. <>= procedure :: to_pair => helicity_to_pair <>= pure function helicity_to_pair (hel) result (h) integer, dimension(2) :: h class(helicity_t), intent(in) :: hel h(1) = hel%h2 h(2) = hel%h1 end function helicity_to_pair @ %def helicity_to_pair @ \subsection{Comparisons} When comparing helicities, if either one is undefined, they are considered to match. In other words, an unpolarized particle matches any polarization. In the [[dmatch]] variant, it matches only diagonal helicity. <>= generic :: operator(.match.) => helicity_match generic :: operator(.dmatch.) => helicity_match_diagonal generic :: operator(==) => helicity_eq generic :: operator(/=) => helicity_neq procedure, private :: helicity_match procedure, private :: helicity_match_diagonal procedure, private :: helicity_eq procedure, private :: helicity_neq @ %def .match. .dmatch. == /= <>= elemental function helicity_match (hel1, hel2) result (eq) logical :: eq class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2) else eq = .true. end if end function helicity_match elemental function helicity_match_diagonal (hel1, hel2) result (eq) logical :: eq class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2) else if (hel1%defined) then eq = hel1%h1 == hel1%h2 else if (hel2%defined) then eq = hel2%h1 == hel2%h2 else eq = .true. end if end function helicity_match_diagonal @ %def helicity_match helicity_match_diagonal <>= elemental function helicity_eq (hel1, hel2) result (eq) logical :: eq class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2) else if (.not. hel1%defined .and. .not. hel2%defined) then eq = .true. else eq = .false. end if end function helicity_eq @ %def helicity_eq <>= elemental function helicity_neq (hel1, hel2) result (neq) logical :: neq class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then neq = (hel1%h1 /= hel2%h1) .or. (hel1%h2 /= hel2%h2) else if (.not. hel1%defined .and. .not. hel2%defined) then neq = .false. else neq = .true. end if end function helicity_neq @ %def helicity_neq @ \subsection{Tools} Merge two helicity objects by taking the first entry from the first and the second entry from the second argument. Makes sense only if the input helicities were defined and diagonal. The handling of ghost flags is not well-defined; one should verify beforehand that they match. <>= generic :: operator(.merge.) => merge_helicities procedure, private :: merge_helicities @ %def .merge. <>= elemental function merge_helicities (hel1, hel2) result (hel) type(helicity_t) :: hel class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then call hel%init (hel2%h1, hel1%h1) else if (hel1%defined) then call hel%init (hel1%h2, hel1%h1) else if (hel2%defined) then call hel%init (hel2%h2, hel2%h1) end if end function merge_helicities @ %def merge_helicities @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Colors} This module defines a type and tools for dealing with color information. Each particle can have zero or more (in practice, usually not more than two) color indices. Color indices are positive; flow direction can be determined from the particle nature. While parton shower matrix elements are diagonal in color, some special applications (e.g., subtractions for NLO matrix elements) require non-diagonal color matrices. <<[[colors.f90]]>>= <> module colors <> <> use io_units use diagnostics <> <> <> <> contains <> end module colors @ %def colors @ \subsection{The color type} A particle may have an arbitrary number of color indices (in practice, from zero to two, but more are possible). This object acts as a container. (The current implementation has a fixed array of length two.) The fact that color comes as an array prohibits elemental procedures in some places. (May add interfaces and multi versions where necessary.) The color may be undefined. NOTE: Due to a compiler bug in nagfor 5.2, we do not use allocatable but fixed-size arrays with dimension 2. Only nonzero entries count. This may be more efficient anyway, but gives up some flexibility. However, the squaring algorithm currently works only for singlets, (anti)triplets and octets anyway, so two components are enough. This type has to be generalized (abstract type and specific implementations) when trying to pursue generalized color flows or Monte Carlo over continuous color. <>= public :: color_t <>= type :: color_t private logical :: defined = .false. integer, dimension(2) :: c1 = 0, c2 = 0 logical :: ghost = .false. contains <> end type color_t @ %def color_t @ Initializers: <>= generic :: init => & color_init_trivial, color_init_trivial_ghost, & color_init_array, color_init_array_ghost, & color_init_arrays, color_init_arrays_ghost procedure, private :: color_init_trivial procedure, private :: color_init_trivial_ghost procedure, private :: color_init_array procedure, private :: color_init_array_ghost procedure, private :: color_init_arrays procedure, private :: color_init_arrays_ghost @ Undefined color: array remains unallocated <>= pure subroutine color_init_trivial (col) class(color_t), intent(inout) :: col col%defined = .true. col%c1 = 0 col%c2 = 0 col%ghost = .false. end subroutine color_init_trivial pure subroutine color_init_trivial_ghost (col, ghost) class(color_t), intent(inout) :: col logical, intent(in) :: ghost col%defined = .true. col%c1 = 0 col%c2 = 0 col%ghost = ghost end subroutine color_init_trivial_ghost @ This defines color from an arbitrary length color array, suitable for any representation. We may have two color arrays (non-diagonal matrix elements). This cannot be elemental. The third version assigns an array of colors, using a two-dimensional array as input. <>= pure subroutine color_init_array (col, c1) class(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1 col%defined = .true. col%c1 = pack (c1, c1 /= 0, [0,0]) col%c2 = col%c1 col%ghost = .false. end subroutine color_init_array pure subroutine color_init_array_ghost (col, c1, ghost) class(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1 logical, intent(in) :: ghost call color_init_array (col, c1) col%ghost = ghost end subroutine color_init_array_ghost pure subroutine color_init_arrays (col, c1, c2) class(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1, c2 col%defined = .true. if (size (c1) == size (c2)) then col%c1 = pack (c1, c1 /= 0, [0,0]) col%c2 = pack (c2, c2 /= 0, [0,0]) else if (size (c1) /= 0) then col%c1 = pack (c1, c1 /= 0, [0,0]) col%c2 = col%c1 else if (size (c2) /= 0) then col%c1 = pack (c2, c2 /= 0, [0,0]) col%c2 = col%c1 end if col%ghost = .false. end subroutine color_init_arrays pure subroutine color_init_arrays_ghost (col, c1, c2, ghost) class(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1, c2 logical, intent(in) :: ghost call color_init_arrays (col, c1, c2) col%ghost = ghost end subroutine color_init_arrays_ghost @ %def color_init @ This version is restricted to singlets, triplets, antitriplets, and octets: The input contains the color and anticolor index, each of the may be zero. <>= procedure :: init_col_acl => color_init_col_acl <>= elemental subroutine color_init_col_acl (col, col_in, acl_in) class(color_t), intent(inout) :: col integer, intent(in) :: col_in, acl_in integer, dimension(0) :: null_array select case (col_in) case (0) select case (acl_in) case (0) call color_init_array (col, null_array) case default call color_init_array (col, [-acl_in]) end select case default select case (acl_in) case (0) call color_init_array (col, [col_in]) case default call color_init_array (col, [col_in, -acl_in]) end select end select end subroutine color_init_col_acl @ %def color_init_col_acl @ This version is used for the external interface. We convert a fixed-size array of colors (for each particle) to the internal form by packing only the nonzero entries. Some of these procedures produce an arry, so they can't be all type-bound. We implement them as ordinary procedures. <>= public :: color_init_from_array <>= interface color_init_from_array module procedure color_init_from_array1 module procedure color_init_from_array1g module procedure color_init_from_array2 module procedure color_init_from_array2g end interface color_init_from_array @ %def color_init_from_array <>= pure subroutine color_init_from_array1 (col, c1) type(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1 logical, dimension(size(c1)) :: mask mask = c1 /= 0 col%defined = .true. col%c1 = pack (c1, mask, col%c1) col%c2 = col%c1 col%ghost = .false. end subroutine color_init_from_array1 pure subroutine color_init_from_array1g (col, c1, ghost) type(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1 logical, intent(in) :: ghost call color_init_from_array1 (col, c1) col%ghost = ghost end subroutine color_init_from_array1g pure subroutine color_init_from_array2 (col, c1) integer, dimension(:,:), intent(in) :: c1 type(color_t), dimension(:), intent(inout) :: col integer :: i do i = 1, size (c1,2) call color_init_from_array1 (col(i), c1(:,i)) end do end subroutine color_init_from_array2 pure subroutine color_init_from_array2g (col, c1, ghost) integer, dimension(:,:), intent(in) :: c1 type(color_t), dimension(:), intent(out) :: col logical, intent(in), dimension(:) :: ghost call color_init_from_array2 (col, c1) col%ghost = ghost end subroutine color_init_from_array2g @ %def color_init_from_array @ Set the ghost property <>= procedure :: set_ghost => color_set_ghost <>= elemental subroutine color_set_ghost (col, ghost) class(color_t), intent(inout) :: col logical, intent(in) :: ghost col%ghost = ghost end subroutine color_set_ghost @ %def color_set_ghost @ Undefine the color state: <>= procedure :: undefine => color_undefine <>= elemental subroutine color_undefine (col, undefine_ghost) class(color_t), intent(inout) :: col logical, intent(in), optional :: undefine_ghost col%defined = .false. if (present (undefine_ghost)) then if (undefine_ghost) col%ghost = .false. else col%ghost = .false. end if end subroutine color_undefine @ %def color_undefine @ Output. As dense as possible, no linebreak. If color is undefined, no output. The separate version for a color array suggest two distinct interfaces. <>= public :: color_write <>= interface color_write module procedure color_write_single module procedure color_write_array end interface color_write <>= procedure :: write => color_write_single <>= subroutine color_write_single (col, unit) class(color_t), intent(in) :: col integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (col%ghost) then write (u, "(A)", advance="no") "c*" else if (col%defined) then write (u, "(A)", advance="no") "c(" if (col%c1(1) /= 0) write (u, "(I0)", advance="no") col%c1(1) if (any (col%c1 /= 0)) write (u, "(1x)", advance="no") if (col%c1(2) /= 0) write (u, "(I0)", advance="no") col%c1(2) if (.not. col%is_diagonal ()) then write (u, "(A)", advance="no") "|" if (col%c2(1) /= 0) write (u, "(I0)", advance="no") col%c2(1) if (any (col%c2 /= 0)) write (u, "(1x)", advance="no") if (col%c2(2) /= 0) write (u, "(I0)", advance="no") col%c2(2) end if write (u, "(A)", advance="no") ")" end if end subroutine color_write_single subroutine color_write_array (col, unit) type(color_t), dimension(:), intent(in) :: col integer, intent(in), optional :: unit integer :: u integer :: i u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance="no") "[" do i = 1, size (col) if (i > 1) write (u, "(1x)", advance="no") call color_write_single (col(i), u) end do write (u, "(A)", advance="no") "]" end subroutine color_write_array @ %def color_write @ Binary I/O. For allocatable colors, this would have to be modified. <>= procedure :: write_raw => color_write_raw procedure :: read_raw => color_read_raw <>= subroutine color_write_raw (col, u) class(color_t), intent(in) :: col integer, intent(in) :: u logical :: defined defined = col%is_defined () .or. col%is_ghost () write (u) defined if (defined) then write (u) col%c1, col%c2 write (u) col%ghost end if end subroutine color_write_raw subroutine color_read_raw (col, u, iostat) class(color_t), intent(inout) :: col integer, intent(in) :: u integer, intent(out), optional :: iostat logical :: defined read (u, iostat=iostat) col%defined if (col%defined) then read (u, iostat=iostat) col%c1, col%c2 read (u, iostat=iostat) col%ghost end if end subroutine color_read_raw @ %def color_write_raw color_read_raw @ \subsection{Predicates} Return the definition status. A color state may be defined but trivial. <>= procedure :: is_defined => color_is_defined procedure :: is_nonzero => color_is_nonzero <>= elemental function color_is_defined (col) result (defined) logical :: defined class(color_t), intent(in) :: col defined = col%defined end function color_is_defined elemental function color_is_nonzero (col) result (flag) logical :: flag class(color_t), intent(in) :: col flag = col%defined & .and. .not. col%ghost & .and. any (col%c1 /= 0 .or. col%c2 /= 0) end function color_is_nonzero @ %def color_is_defined @ %def color_is_nonzero @ Diagonal color objects have only one array allocated: <>= procedure :: is_diagonal => color_is_diagonal <>= elemental function color_is_diagonal (col) result (diagonal) logical :: diagonal class(color_t), intent(in) :: col if (col%defined) then diagonal = all (col%c1 == col%c2) else diagonal = .true. end if end function color_is_diagonal @ %def color_is_diagonal @ Return the ghost flag <>= procedure :: is_ghost => color_is_ghost <>= elemental function color_is_ghost (col) result (ghost) logical :: ghost class(color_t), intent(in) :: col ghost = col%ghost end function color_is_ghost @ %def color_is_ghost @ The ghost parity: true if the color-ghost flag is set. Again, no TBP since this is an array. <>= pure function color_ghost_parity (col) result (parity) type(color_t), dimension(:), intent(in) :: col logical :: parity parity = mod (count (col%ghost), 2) == 1 end function color_ghost_parity @ %def color_ghost_parity @ Determine the color representation, given a color object. We allow only singlet ($1$), (anti)triplet ($\pm 3$), and octet states ($8$). A color ghost must not have color assigned, but the color type is $8$. For non-diagonal color, representations must match. If the color type is undefined, return $0$. If it is invalid or unsupported, return $-1$. Assumption: nonzero entries precede nonzero ones. <>= procedure :: get_type => color_get_type <>= elemental function color_get_type (col) result (ctype) class(color_t), intent(in) :: col integer :: ctype if (col%defined) then ctype = -1 if (col%ghost) then if (all (col%c1 == 0 .and. col%c2 == 0)) then ctype = 8 end if else if (all ((col%c1 == 0 .and. col%c2 == 0) & & .or. (col%c1 > 0 .and. col%c2 > 0) & & .or. (col%c1 < 0 .and. col%c2 < 0))) then if (all (col%c1 == 0)) then ctype = 1 else if ((col%c1(1) > 0 .and. col%c1(2) == 0)) then ctype = 3 else if ((col%c1(1) < 0 .and. col%c1(2) == 0)) then ctype = -3 else if ((col%c1(1) > 0 .and. col%c1(2) < 0) & .or.(col%c1(1) < 0 .and. col%c1(2) > 0)) then ctype = 8 end if end if end if else ctype = 0 end if end function color_get_type @ %def color_get_type @ \subsection{Accessing contents} Return the number of color indices. We assume that it is identical for both arrays. <>= procedure, private :: get_number_of_indices => color_get_number_of_indices <>= elemental function color_get_number_of_indices (col) result (n) integer :: n class(color_t), intent(in) :: col if (col%defined .and. .not. col%ghost) then n = count (col%c1 /= 0) else n = 0 end if end function color_get_number_of_indices @ %def color_get_number_of_indices @ Return the (first) color/anticolor entry (assuming that color is diagonal). The result is a positive color index. <>= procedure :: get_col => color_get_col procedure :: get_acl => color_get_acl <>= elemental function color_get_col (col) result (c) integer :: c class(color_t), intent(in) :: col integer :: i if (col%defined .and. .not. col%ghost) then do i = 1, size (col%c1) if (col%c1(i) > 0) then c = col%c1(i) return end if end do end if c = 0 end function color_get_col elemental function color_get_acl (col) result (c) integer :: c class(color_t), intent(in) :: col integer :: i if (col%defined .and. .not. col%ghost) then do i = 1, size (col%c1) if (col%c1(i) < 0) then c = - col%c1(i) return end if end do end if c = 0 end function color_get_acl @ %def color_get_col color_get_acl @ Return the color index with highest absolute value <>= public :: color_get_max_value <>= interface color_get_max_value module procedure color_get_max_value0 module procedure color_get_max_value1 module procedure color_get_max_value2 end interface color_get_max_value <>= elemental function color_get_max_value0 (col) result (cmax) integer :: cmax type(color_t), intent(in) :: col if (col%defined .and. .not. col%ghost) then cmax = maxval (abs (col%c1)) else cmax = 0 end if end function color_get_max_value0 pure function color_get_max_value1 (col) result (cmax) integer :: cmax type(color_t), dimension(:), intent(in) :: col cmax = maxval (color_get_max_value0 (col)) end function color_get_max_value1 pure function color_get_max_value2 (col) result (cmax) integer :: cmax type(color_t), dimension(:,:), intent(in) :: col integer, dimension(size(col, 2)) :: cm integer :: i forall (i = 1:size(col, 2)) cm(i) = color_get_max_value1 (col(:,i)) end forall cmax = maxval (cm) end function color_get_max_value2 @ %def color_get_max_value @ \subsection{Comparisons} Similar to helicities, colors match if they are equal, or if either one is undefined. <>= generic :: operator(.match.) => color_match generic :: operator(==) => color_eq generic :: operator(/=) => color_neq procedure, private :: color_match procedure, private :: color_eq procedure, private :: color_neq @ %def .match. == /= <>= elemental function color_match (col1, col2) result (eq) logical :: eq class(color_t), intent(in) :: col1, col2 if (col1%defined .and. col2%defined) then if (col1%ghost .and. col2%ghost) then eq = .true. else if (.not. col1%ghost .and. .not. col2%ghost) then eq = all (col1%c1 == col2%c1) .and. all (col1%c2 == col2%c2) else eq = .false. end if else eq = .true. end if end function color_match elemental function color_eq (col1, col2) result (eq) logical :: eq class(color_t), intent(in) :: col1, col2 if (col1%defined .and. col2%defined) then if (col1%ghost .and. col2%ghost) then eq = .true. else if (.not. col1%ghost .and. .not. col2%ghost) then eq = all (col1%c1 == col2%c1) .and. all (col1%c2 == col2%c2) else eq = .false. end if else if (.not. col1%defined & .and. .not. col2%defined) then eq = col1%ghost .eqv. col2%ghost else eq = .false. end if end function color_eq @ %def color_eq <>= elemental function color_neq (col1, col2) result (neq) logical :: neq class(color_t), intent(in) :: col1, col2 if (col1%defined .and. col2%defined) then if (col1%ghost .and. col2%ghost) then neq = .false. else if (.not. col1%ghost .and. .not. col2%ghost) then neq = any (col1%c1 /= col2%c1) .or. any (col1%c2 /= col2%c2) else neq = .true. end if else if (.not. col1%defined & .and. .not. col2%defined) then neq = col1%ghost .neqv. col2%ghost else neq = .true. end if end function color_neq @ %def color_neq @ \subsection{Tools} Shift color indices by a common offset. <>= procedure :: add_offset => color_add_offset <>= elemental subroutine color_add_offset (col, offset) class(color_t), intent(inout) :: col integer, intent(in) :: offset if (col%defined .and. .not. col%ghost) then where (col%c1 /= 0) col%c1 = col%c1 + sign (offset, col%c1) where (col%c2 /= 0) col%c2 = col%c2 + sign (offset, col%c2) end if end subroutine color_add_offset @ %def color_add_offset @ Reassign color indices for an array of colored particle in canonical order. The allocated size of the color map is such that two colors per particle can be accomodated. The algorithm works directly on the contents of the color objects, it <>= public :: color_canonicalize <>= subroutine color_canonicalize (col) type(color_t), dimension(:), intent(inout) :: col integer, dimension(2*size(col)) :: map integer :: n_col, i, j, k n_col = 0 do i = 1, size (col) if (col(i)%defined .and. .not. col(i)%ghost) then do j = 1, size (col(i)%c1) if (col(i)%c1(j) /= 0) then k = find (abs (col(i)%c1(j)), map(:n_col)) if (k == 0) then n_col = n_col + 1 map(n_col) = abs (col(i)%c1(j)) k = n_col end if col(i)%c1(j) = sign (k, col(i)%c1(j)) end if if (col(i)%c2(j) /= 0) then k = find (abs (col(i)%c2(j)), map(:n_col)) if (k == 0) then n_col = n_col + 1 map(n_col) = abs (col(i)%c2(j)) k = n_col end if col(i)%c2(j) = sign (k, col(i)%c2(j)) end if end do end if end do contains function find (c, array) result (k) integer :: k integer, intent(in) :: c integer, dimension(:), intent(in) :: array integer :: i k = 0 do i = 1, size (array) if (c == array (i)) then k = i return end if end do end function find end subroutine color_canonicalize @ %def color_canonicalize @ Return an array of different color indices from an array of colors. The last argument is a pseudo-color array, where the color entries correspond to the position of the corresponding index entry in the index array. The colors are assumed to be diagonal. The algorithm works directly on the contents of the color objects. <>= subroutine extract_color_line_indices (col, c_index, col_pos) type(color_t), dimension(:), intent(in) :: col integer, dimension(:), intent(out), allocatable :: c_index type(color_t), dimension(size(col)), intent(out) :: col_pos integer, dimension(:), allocatable :: c_tmp integer :: i, j, k, n, c allocate (c_tmp (sum (col%get_number_of_indices ())), source=0) n = 0 SCAN1: do i = 1, size (col) if (col(i)%defined .and. .not. col(i)%ghost) then SCAN2: do j = 1, 2 c = abs (col(i)%c1(j)) if (c /= 0) then do k = 1, n if (c_tmp(k) == c) then col_pos(i)%c1(j) = k cycle SCAN2 end if end do n = n + 1 c_tmp(n) = c col_pos(i)%c1(j) = n end if end do SCAN2 end if end do SCAN1 allocate (c_index (n)) c_index = c_tmp(1:n) end subroutine extract_color_line_indices @ %def extract_color_line_indices @ Given a color array, pairwise contract the color lines in all possible ways and return the resulting array of arrays. The input color array must be diagonal, and each color should occur exactly twice, once as color and once as anticolor. Gluon entries with equal color and anticolor are explicitly excluded. This algorithm is generic, but for long arrays it is neither efficient, nor does it avoid duplicates. It is intended for small arrays, in particular for the state matrix of a structure-function pair. The algorithm works directly on the contents of the color objects, it thus depends on the implementation. <>= public :: color_array_make_contractions <>= subroutine color_array_make_contractions (col_in, col_out) type(color_t), dimension(:), intent(in) :: col_in type(color_t), dimension(:,:), intent(out), allocatable :: col_out type :: entry_t integer, dimension(:), allocatable :: map type(color_t), dimension(:), allocatable :: col type(entry_t), pointer :: next => null () logical :: nlo_event = .false. end type entry_t type :: list_t integer :: n = 0 type(entry_t), pointer :: first => null () type(entry_t), pointer :: last => null () end type list_t type(list_t) :: list type(entry_t), pointer :: entry integer, dimension(:), allocatable :: c_index type(color_t), dimension(size(col_in)) :: col_pos integer :: n_prt, n_c_index integer, dimension(:), allocatable :: map integer :: i, j, c n_prt = size (col_in) call extract_color_line_indices (col_in, c_index, col_pos) n_c_index = size (c_index) allocate (map (n_c_index)) map = 0 call list_append_if_valid (list, map) entry => list%first do while (associated (entry)) do i = 1, n_c_index if (entry%map(i) == 0) then c = c_index(i) do j = i + 1, n_c_index if (entry%map(j) == 0) then map = entry%map map(i) = c map(j) = c call list_append_if_valid (list, map) end if end do end if end do entry => entry%next end do call list_to_array (list, col_out) contains subroutine list_append_if_valid (list, map) type(list_t), intent(inout) :: list integer, dimension(:), intent(in) :: map type(entry_t), pointer :: entry integer :: i, j, c, p entry => list%first do while (associated (entry)) if (all (map == entry%map)) return entry => entry%next end do allocate (entry) allocate (entry%map (n_c_index)) entry%map = map allocate (entry%col (n_prt)) do i = 1, n_prt do j = 1, 2 c = col_in(i)%c1(j) if (c /= 0) then p = col_pos(i)%c1(j) entry%col(i)%defined = .true. if (map(p) /= 0) then entry%col(i)%c1(j) = sign (map(p), c) else entry%col(i)%c1(j) = c endif entry%col(i)%c2(j) = entry%col(i)%c1(j) end if end do if (any (entry%col(i)%c1 /= 0) .and. & entry%col(i)%c1(1) == - entry%col(i)%c1(2)) return end do if (associated (list%last)) then list%last%next => entry else list%first => entry end if list%last => entry list%n = list%n + 1 end subroutine list_append_if_valid subroutine list_to_array (list, col) type(list_t), intent(inout) :: list type(color_t), dimension(:,:), intent(out), allocatable :: col type(entry_t), pointer :: entry integer :: i allocate (col (n_prt, list%n - 1)) do i = 0, list%n - 1 entry => list%first list%first => list%first%next if (i /= 0) col(:,i) = entry%col deallocate (entry) end do list%last => null () end subroutine list_to_array end subroutine color_array_make_contractions @ %def color_array_make_contractions @ Invert the color index, switching from particle to antiparticle. For gluons, we have to swap the order of color entries. <>= procedure :: invert => color_invert <>= elemental subroutine color_invert (col) class(color_t), intent(inout) :: col if (col%defined .and. .not. col%ghost) then col%c1 = - col%c1 col%c2 = - col%c2 if (col%c1(1) < 0 .and. col%c1(2) > 0) then col%c1 = col%c1(2:1:-1) col%c2 = col%c2(2:1:-1) end if end if end subroutine color_invert @ %def color_invert @ Make a color map for two matching color arrays. The result is an array of integer pairs. <>= public :: make_color_map <>= interface make_color_map module procedure color_make_color_map end interface make_color_map <>= subroutine color_make_color_map (map, col1, col2) integer, dimension(:,:), intent(out), allocatable :: map type(color_t), dimension(:), intent(in) :: col1, col2 integer, dimension(:,:), allocatable :: map1 integer :: i, j, k allocate (map1 (2, 2 * sum (col1%get_number_of_indices ()))) k = 0 do i = 1, size (col1) if (col1(i)%defined .and. .not. col1(i)%ghost) then do j = 1, size (col1(i)%c1) if (col1(i)%c1(j) /= 0 & .and. all (map1(1,:k) /= abs (col1(i)%c1(j)))) then k = k + 1 map1(1,k) = abs (col1(i)%c1(j)) map1(2,k) = abs (col2(i)%c1(j)) end if if (col1(i)%c2(j) /= 0 & .and. all (map1(1,:k) /= abs (col1(i)%c2(j)))) then k = k + 1 map1(1,k) = abs (col1(i)%c2(j)) map1(2,k) = abs (col2(i)%c2(j)) end if end do end if end do allocate (map (2, k)) map(:,:) = map1(:,:k) end subroutine color_make_color_map @ %def make_color_map @ Translate colors which have a match in the translation table (an array of integer pairs). Color that do not match an entry are simply transferred; this is done by first transferring all components, then modifiying entries where appropriate. <>= public :: color_translate <>= interface color_translate module procedure color_translate0 module procedure color_translate0_offset module procedure color_translate1 end interface color_translate <>= subroutine color_translate0 (col, map) type(color_t), intent(inout) :: col integer, dimension(:,:), intent(in) :: map type(color_t) :: col_tmp integer :: i if (col%defined .and. .not. col%ghost) then col_tmp = col do i = 1, size (map,2) where (abs (col%c1) == map(1,i)) col_tmp%c1 = sign (map(2,i), col%c1) end where where (abs (col%c2) == map(1,i)) col_tmp%c2 = sign (map(2,i), col%c2) end where end do col = col_tmp end if end subroutine color_translate0 subroutine color_translate0_offset (col, map, offset) type(color_t), intent(inout) :: col integer, dimension(:,:), intent(in) :: map integer, intent(in) :: offset logical, dimension(size(col%c1)) :: mask1, mask2 type(color_t) :: col_tmp integer :: i if (col%defined .and. .not. col%ghost) then col_tmp = col mask1 = col%c1 /= 0 mask2 = col%c2 /= 0 do i = 1, size (map,2) where (abs (col%c1) == map(1,i)) col_tmp%c1 = sign (map(2,i), col%c1) mask1 = .false. end where where (abs (col%c2) == map(1,i)) col_tmp%c2 = sign (map(2,i), col%c2) mask2 = .false. end where end do col = col_tmp where (mask1) col%c1 = sign (abs (col%c1) + offset, col%c1) where (mask2) col%c2 = sign (abs (col%c2) + offset, col%c2) end if end subroutine color_translate0_offset subroutine color_translate1 (col, map, offset) type(color_t), dimension(:), intent(inout) :: col integer, dimension(:,:), intent(in) :: map integer, intent(in), optional :: offset integer :: i if (present (offset)) then do i = 1, size (col) call color_translate0_offset (col(i), map, offset) end do else do i = 1, size (col) call color_translate0 (col(i), map) end do end if end subroutine color_translate1 @ %def color_translate @ Merge two color objects by taking the first entry from the first and the first entry from the second argument. Makes sense only if the input colors are defined (and diagonal). If either one is undefined, transfer the defined one. <>= generic :: operator(.merge.) => merge_colors procedure, private :: merge_colors @ %def .merge. <>= elemental function merge_colors (col1, col2) result (col) type(color_t) :: col class(color_t), intent(in) :: col1, col2 if (color_is_defined (col1) .and. color_is_defined (col2)) then if (color_is_ghost (col1) .and. color_is_ghost (col2)) then call color_init_trivial_ghost (col, .true.) else call color_init_arrays (col, col1%c1, col2%c1) end if else if (color_is_defined (col1)) then call color_init_array (col, col1%c1) else if (color_is_defined (col2)) then call color_init_array (col, col2%c1) end if end function merge_colors @ %def merge_colors @ Merge up to two (diagonal!) color objects. The result inherits the unmatched color lines of the input colors. If one of the input colors is undefined, the output is undefined as well. It must be in a supported color representation. A color-ghost object should not actually occur in real-particle events, but for completeness we define its behavior. For simplicity, it is identified as a color-octet with zero color/anticolor. It can only couple to a triplet or antitriplet. A fusion of triplet with matching antitriplet will yield a singlet, not a ghost, however. If the fusion fails, the result is undefined. <>= generic :: operator (.fuse.) => color_fusion procedure, private :: color_fusion <>= function color_fusion (col1, col2) result (col) class(color_t), intent(in) :: col1, col2 type(color_t) :: col integer, dimension(2) :: ctype if (col1%is_defined () .and. col2%is_defined ()) then if (col1%is_diagonal () .and. col2%is_diagonal ()) then ctype = [col1%get_type (), col2%get_type ()] select case (ctype(1)) case (1) select case (ctype(2)) case (1,3,-3,8) col = col2 end select case (3) select case (ctype(2)) case (1) col = col1 case (-3) call t_a (col1%get_col (), col2%get_acl ()) case (8) call t_o (col1%get_col (), col2%get_acl (), & & col2%get_col ()) end select case (-3) select case (ctype(2)) case (1) col = col1 case (3) call t_a (col2%get_col (), col1%get_acl ()) case (8) call a_o (col1%get_acl (), col2%get_col (), & & col2%get_acl ()) end select case (8) select case (ctype(2)) case (1) col = col1 case (3) call t_o (col2%get_col (), col1%get_acl (), & & col1%get_col ()) case (-3) call a_o (col2%get_acl (), col1%get_col (), & & col1%get_acl ()) case (8) call o_o (col1%get_col (), col1%get_acl (), & & col2%get_col (), col2%get_acl ()) end select end select end if end if contains subroutine t_a (c1, c2) integer, intent(in) :: c1, c2 if (c1 == c2) then call col%init_col_acl (0, 0) else call col%init_col_acl (c1, c2) end if end subroutine t_a subroutine t_o (c1, c2, c3) integer, intent(in) :: c1, c2, c3 if (c1 == c2) then call col%init_col_acl (c3, 0) else if (c2 == 0 .and. c3 == 0) then call col%init_col_acl (c1, 0) end if end subroutine t_o subroutine a_o (c1, c2, c3) integer, intent(in) :: c1, c2, c3 if (c1 == c2) then call col%init_col_acl (0, c3) else if (c2 == 0 .and. c3 == 0) then call col%init_col_acl (0, c1) end if end subroutine a_o subroutine o_o (c1, c2, c3, c4) integer, intent(in) :: c1, c2, c3, c4 if (all ([c1,c2,c3,c4] /= 0)) then if (c2 == c3 .and. c4 == c1) then call col%init_col_acl (0, 0) else if (c2 == c3) then call col%init_col_acl (c1, c4) else if (c4 == c1) then call col%init_col_acl (c3, c2) end if end if end subroutine o_o end function color_fusion @ %def color_fusion @ Compute the color factor, given two interfering color arrays. <>= public :: compute_color_factor <>= function compute_color_factor (col1, col2, nc) result (factor) real(default) :: factor type(color_t), dimension(:), intent(in) :: col1, col2 integer, intent(in), optional :: nc type(color_t), dimension(size(col1)) :: col integer :: ncol, nloops, nghost ncol = 3; if (present (nc)) ncol = nc col = col1 .merge. col2 nloops = count_color_loops (col) nghost = count (col%is_ghost ()) factor = real (ncol, default) ** (nloops - nghost) if (color_ghost_parity (col)) factor = - factor end function compute_color_factor @ %def compute_color_factor @ We have a pair of color index arrays which corresponds to a squared matrix element. We want to determine the number of color loops in this square matrix element. So we first copy the colors (stored in a single color array with a pair of color lists in each entry) to a temporary where the color indices are shifted by some offset. We then recursively follow each loop, starting at the first color that has the offset, resetting the first color index to the loop index and each further index to zero as we go. We check that (a) each color index occurs twice within the left (right) color array, (b) the loops are closed, so we always come back to a line which has the loop index. In order for the algorithm to work we have to conjugate the colors of initial state particles (one for decays, two for scatterings) into their corresponding anticolors of outgoing particles. <>= public :: count_color_loops <>= function count_color_loops (col) result (count) integer :: count type(color_t), dimension(:), intent(in) :: col type(color_t), dimension(size(col)) :: cc integer :: i, n, offset cc = col n = size (cc) offset = n call color_add_offset (cc, offset) count = 0 SCAN_LOOPS: do do i = 1, n if (color_is_nonzero (cc(i))) then if (any (cc(i)%c1 > offset)) then count = count + 1 call follow_line1 (pick_new_line (cc(i)%c1, count, 1)) cycle SCAN_LOOPS end if end if end do exit SCAN_LOOPS end do SCAN_LOOPS contains function pick_new_line (c, reset_val, sgn) result (line) integer :: line integer, dimension(:), intent(inout) :: c integer, intent(in) :: reset_val integer, intent(in) :: sgn integer :: i if (any (c == count)) then line = count else do i = 1, size (c) if (sign (1, c(i)) == sgn .and. abs (c(i)) > offset) then line = c(i) c(i) = reset_val return end if end do call color_mismatch end if end function pick_new_line subroutine reset_line (c, line) integer, dimension(:), intent(inout) :: c integer, intent(in) :: line integer :: i do i = 1, size (c) if (c(i) == line) then c(i) = 0 return end if end do end subroutine reset_line recursive subroutine follow_line1 (line) integer, intent(in) :: line integer :: i if (line == count) return do i = 1, n if (any (cc(i)%c1 == -line)) then call reset_line (cc(i)%c1, -line) call follow_line2 (pick_new_line (cc(i)%c2, 0, sign (1, -line))) return end if end do call color_mismatch () end subroutine follow_line1 recursive subroutine follow_line2 (line) integer, intent(in) :: line integer :: i do i = 1, n if (any (cc(i)%c2 == -line)) then call reset_line (cc(i)%c2, -line) call follow_line1 (pick_new_line (cc(i)%c1, 0, sign (1, -line))) return end if end do call color_mismatch () end subroutine follow_line2 subroutine color_mismatch () call color_write (col) print * call msg_fatal ("Color flow mismatch: Non-closed color lines appear during ", & [var_str ("the evaluation of color correlations. This can happen if there "), & var_str ("are different color structures in the initial or final state of "), & var_str ("the process definition. If so, please use separate processes for "), & var_str ("the different initial / final states. In a future WHIZARD version "), & var_str ("this will be fixed.")]) end subroutine color_mismatch end function count_color_loops @ %def count_color_loops @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[colors_ut.f90]]>>= <> module colors_ut use unit_tests use colors_uti <> <> contains <> end module colors_ut @ %def colors_ut @ <<[[colors_uti.f90]]>>= <> module colors_uti use colors <> <> contains <> end module colors_uti @ %def colors_ut @ API: driver for the unit tests below. <>= public :: color_test <>= subroutine color_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine color_test @ %def color_test @ This is a color counting test. <>= call test (color_1, "color_1", & "check color counting", & u, results) <>= public :: color_1 <>= subroutine color_1 (u) integer, intent(in) :: u type(color_t), dimension(4) :: col1, col2, col type(color_t), dimension(:), allocatable :: col3 type(color_t), dimension(:,:), allocatable :: col_array integer :: count, i call col1%init_col_acl ([1, 0, 2, 3], [0, 1, 3, 2]) col2 = col1 call color_write (col1, u) write (u, "(A)") call color_write (col2, u) write (u, "(A)") col = col1 .merge. col2 call color_write (col, u) write (u, "(A)") count = count_color_loops (col) write (u, "(A,I1)") "Number of color loops (3): ", count call col2%init_col_acl ([1, 0, 2, 3], [0, 2, 3, 1]) call color_write (col1, u) write (u, "(A)") call color_write (col2, u) write (u, "(A)") col = col1 .merge. col2 call color_write (col, u) write (u, "(A)") count = count_color_loops (col) write (u, "(A,I1)") "Number of color loops (2): ", count write (u, "(A)") allocate (col3 (4)) call color_init_from_array (col3, & reshape ([1, 0, 0, -1, 2, -3, 3, -2], & [2, 4])) call color_write (col3, u) write (u, "(A)") call color_array_make_contractions (col3, col_array) write (u, "(A)") "Contractions:" do i = 1, size (col_array, 2) call color_write (col_array(:,i), u) write (u, "(A)") end do deallocate (col3) write (u, "(A)") allocate (col3 (6)) call color_init_from_array (col3, & reshape ([1, -2, 3, 0, 0, -1, 2, -4, -3, 0, 4, 0], & [2, 6])) call color_write (col3, u) write (u, "(A)") call color_array_make_contractions (col3, col_array) write (u, "(A)") "Contractions:" do i = 1, size (col_array, 2) call color_write (col_array(:,i), u) write (u, "(A)") end do end subroutine color_1 @ %def color_1 @ A color fusion test. <>= call test (color_2, "color_2", & "color fusion", & u, results) <>= public :: color_2 <>= subroutine color_2 (u) integer, intent(in) :: u type(color_t) :: s1, t1, t2, a1, a2, o1, o2, o3, o4, g1 write (u, "(A)") "* Test output: color_2" write (u, "(A)") "* Purpose: test all combinations for color-object fusion" write (u, "(A)") call s1%init_col_acl (0,0) call t1%init_col_acl (1,0) call t2%init_col_acl (2,0) call a1%init_col_acl (0,1) call a2%init_col_acl (0,2) call o1%init_col_acl (1,2) call o2%init_col_acl (1,3) call o3%init_col_acl (2,3) call o4%init_col_acl (2,1) call g1%init (ghost=.true.) call wrt ("s1", s1) call wrt ("t1", t1) call wrt ("t2", t2) call wrt ("a1", a1) call wrt ("a2", a2) call wrt ("o1", o1) call wrt ("o2", o2) call wrt ("o3", o3) call wrt ("o4", o4) call wrt ("g1", g1) write (u, *) call wrt ("s1 * s1", s1 .fuse. s1) write (u, *) call wrt ("s1 * t1", s1 .fuse. t1) call wrt ("s1 * a1", s1 .fuse. a1) call wrt ("s1 * o1", s1 .fuse. o1) write (u, *) call wrt ("t1 * s1", t1 .fuse. s1) call wrt ("a1 * s1", a1 .fuse. s1) call wrt ("o1 * s1", o1 .fuse. s1) write (u, *) call wrt ("t1 * t1", t1 .fuse. t1) write (u, *) call wrt ("t1 * t2", t1 .fuse. t2) call wrt ("t1 * a1", t1 .fuse. a1) call wrt ("t1 * a2", t1 .fuse. a2) call wrt ("t1 * o1", t1 .fuse. o1) call wrt ("t2 * o1", t2 .fuse. o1) write (u, *) call wrt ("t2 * t1", t2 .fuse. t1) call wrt ("a1 * t1", a1 .fuse. t1) call wrt ("a2 * t1", a2 .fuse. t1) call wrt ("o1 * t1", o1 .fuse. t1) call wrt ("o1 * t2", o1 .fuse. t2) write (u, *) call wrt ("a1 * a1", a1 .fuse. a1) write (u, *) call wrt ("a1 * a2", a1 .fuse. a2) call wrt ("a1 * o1", a1 .fuse. o1) call wrt ("a2 * o2", a2 .fuse. o2) write (u, *) call wrt ("a2 * a1", a2 .fuse. a1) call wrt ("o1 * a1", o1 .fuse. a1) call wrt ("o2 * a2", o2 .fuse. a2) write (u, *) call wrt ("o1 * o1", o1 .fuse. o1) write (u, *) call wrt ("o1 * o2", o1 .fuse. o2) call wrt ("o1 * o3", o1 .fuse. o3) call wrt ("o1 * o4", o1 .fuse. o4) write (u, *) call wrt ("o2 * o1", o2 .fuse. o1) call wrt ("o3 * o1", o3 .fuse. o1) call wrt ("o4 * o1", o4 .fuse. o1) write (u, *) call wrt ("g1 * g1", g1 .fuse. g1) write (u, *) call wrt ("g1 * s1", g1 .fuse. s1) call wrt ("g1 * t1", g1 .fuse. t1) call wrt ("g1 * a1", g1 .fuse. a1) call wrt ("g1 * o1", g1 .fuse. o1) write (u, *) call wrt ("s1 * g1", s1 .fuse. g1) call wrt ("t1 * g1", t1 .fuse. g1) call wrt ("a1 * g1", a1 .fuse. g1) call wrt ("o1 * g1", o1 .fuse. g1) write (u, "(A)") write (u, "(A)") "* Test output end: color_2" contains subroutine wrt (s, col) character(*), intent(in) :: s class(color_t), intent(in) :: col write (u, "(A,1x,'=',1x)", advance="no") s call col%write (u) write (u, *) end subroutine wrt end subroutine color_2 @ %def color_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{The Madgraph color model} This section describes the method for matrix element and color flow calculation within Madgraph. For each Feynman diagram, the colorless amplitude for a specified helicity and momentum configuration (in- and out- combined) is computed: \begin{equation} A_d(p,h) \end{equation} Inserting color, the squared matrix element for definite helicity and momentum is \begin{equation} M^2(p,h) = \sum_{dd'} A_{d}(p,h)\,C_{dd'} A_{d'}^*(p,h) \end{equation} where $C_{dd'}$ describes the color interference of the two diagrams $A_d$ and $A_d'$, which is independent of momentum and helicity and can be calculated for each Feynman diagram pair by reducing it to the corresponding color graph. Obviously, one could combine all diagrams with identical color structure, such that the index $d$ runs only over different color graphs. For colorless diagrams all elements of $C_{dd'}$ are equal to unity. The hermitian matrix $C_{dd'}$ is diagonalized once and for all, such that it can be written in the form \begin{equation} C_{dd'} = \sum_\lambda c_d^\lambda \lambda\, c_d^\lambda{}^*, \end{equation} where the eigenvectors $c_d$ are normalized, \begin{equation} \sum_d |c_d^\lambda|^2 = 1, \end{equation} and the $\lambda$ values are the corresponding eigenvalues. In the colorless case, this means $c_d = 1/\sqrt{N_d}$ for all diagrams ($N_d=$ number of diagrams), and $\lambda=N_d$ is the only nonzero eigenvalue. Consequently, the squared matrix element for definite helicity and momentum can also be written as \begin{equation} M^2(p,h) = \sum_\lambda A_\lambda(p,h)\, \lambda\, A_\lambda(p,h)^* \end{equation} with \begin{equation} A_\lambda(p,h) = \sum_d c_d^\lambda A_d(p,h). \end{equation} For generic spin density matrices, this is easily generalized to \begin{equation} M^2(p,h,h') = \sum_\lambda A_\lambda(p,h)\, \lambda\, A_\lambda(p,h')^* \end{equation} To determine the color flow probabilities of a given momentum-helicity configuration, the color flow amplitudes are calculated as \begin{equation} a_f(p,h) = \sum_d \beta^f_d A_d(p,h), \end{equation} where the coefficients $\beta^f_d$ describe the amplitude for a given Feynman diagram (or color graph) $d$ to correspond to a definite color flow~$f$. They are computed from $C_{dd'}$ by transforming this matrix into the color flow basis and neglecting all off-diagonal elements. Again, these coefficients do not depend on momentum or helicity and can therefore be calculated in advance. This gives the color flow transition matrix \begin{equation} F^f(p,h,h') = a_f(p,h)\, a^*_f(p,h') \end{equation} which is assumed diagonal in color flow space and is separate from the color-summed transition matrix $M^2$. They are, however, equivalent (up to a factor) to leading order in $1/N_c$, and using the color flow transition matrix is appropriate for matching to hadronization. Note that the color flow transition matrix is not normalized at this stage. To make use of it, we have to fold it with the in-state density matrix to get a pseudo density matrix \begin{equation} \hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out}) = \sum_{h_{\rm in} h'_{\rm in}} F^f(p,h,h')\, \rho_{\rm in}(p,h_{\rm in},h'_{\rm in}) \end{equation} which gets a meaning only after contracted with projections on the outgoing helicity states $k_{\rm out}$, given as linear combinations of helicity states with the unitary coefficient matrix $c(k_{\rm out}, h_{\rm out})$. Then the probability of finding color flow $f$ when the helicity state $k_{\rm out}$ is measured is given by \begin{equation} P^f(p, k_{\rm out}) = Q^f(p, k_{\rm out}) / \sum_f Q^f(p, k_{\rm out}) \end{equation} where \begin{equation} Q^f(p, k_{\rm out}) = \sum_{h_{\rm out} h'_{\rm out}} c(k_{\rm out}, h_{\rm out})\, \hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})\, c^*(k_{\rm out}, h'_{\rm out}) \end{equation} However, if we can assume that the out-state helicity basis is the canonical one, we can throw away the off diagonal elements in the color flow density matrix and normalize the ones on the diagonal to obtain \begin{equation} P^f(p, h_{\rm out}) = \hat\rho_{\rm out}^f(p,h_{\rm out},h_{\rm out}) / \sum_f \hat\rho_{\rm out}^f(p,h_{\rm out},h_{\rm out}) \end{equation} Finally, the color-summed out-state density matrix is computed by the scattering formula \begin{align} {\rho_{\rm out}(p,h_{\rm out},h'_{\rm out})} &= \sum_{h_{\rm in} h'_{\rm in}} M^2(p,h,h')\, \rho_{\rm in}(p,h_{\rm in},h'_{\rm in}) \\ &= \sum_{h_{\rm in} h'_{\rm in} \lambda} A_\lambda(p,h)\, \lambda\, A_\lambda(p,h')^* \rho_{\rm in}(p,h_{\rm in},h'_{\rm in}), \end{align} The trace of $\rho_{\rm out}$ is the squared matrix element, summed over all internal degrees of freedom. To get the squared matrix element for a definite helicity $k_{\rm out}$ and color flow $f$, one has to project the density matrix onto the given helicity state and multiply with $P^f(p, k_{\rm out})$. For diagonal helicities the out-state density reduces to \begin{equation} \rho_{\rm out}(p,h_{\rm out}) = \sum_{h_{\rm in}\lambda} \lambda|A_\lambda(p,h)|^2 \rho_{\rm in}(p,h_{\rm in}). \end{equation} Since no basis transformation is involved, we can use the normalized color flow probability $P^f(p, h_{\rm out})$ and express the result as \begin{align} \rho_{\rm out}^f(p,h_{\rm out}) &= \rho_{\rm out}(p,h_{\rm out})\,P^f(p, h_{\rm out}) \\ &= \sum_{h_{\rm in}\lambda} \frac{|a^f(p,h)|^2}{\sum_f|a^f(p,h)|^2} \lambda|A_\lambda(p,h)|^2 \rho_{\rm in}(p,h_{\rm in}). \end{align} From these considerations, the following calculation strategy can be derived: \begin{itemize} \item Before the first event is generated, the color interference matrix $C_{dd'}$ is computed and diagonalized, so the eigenvectors $c^\lambda_d$, eigenvalues $\lambda$ and color flow coefficients $\beta^f_d$ are obtained. In practice, these calculations are done when the matrix element code is generated, and the results are hardcoded in the matrix element subroutine as [[DATA]] statements. \item For each event, one loops over helicities once and stores the matrices $A_\lambda(p,h)$ and $a^f(p,h)$. The allowed color flows, helicity combinations and eigenvalues are each labeled by integer indices, so one has to store complex matrices of dimension $N_\lambda\times N_h$ and $N_f\times N_h$, respectively. \item The further strategy depends on the requested information. \begin{enumerate} \item If colorless diagonal helicity amplitudes are required, the eigenvalues $A_\lambda(p,h)$ are squared, summed with weight $\lambda$, and the result contracted with the in-state probability vector $\rho_{\rm in}(p, h_{\rm in})$. The result is a probability vector $\rho_{\rm out}(p, h_{\rm out})$. \item For colored diagonal helicity amplitudes, the color coefficients $a^f(p,h)$ are also squared and used as weights to obtain the color-flow probability vector $\rho_{\rm out}^f(p, h_{\rm out})$. \item For colorless non-diagonal helicity amplitudes, we contract the tensor product of $A_\lambda(p,h)$ with $A_\lambda(p,h')$, weighted with $\lambda$, with the correlated in-state density matrix, to obtain a correlated out-state density matrix. \item In the general (colored, non-diagonal) case, we do the same as in the colorless case, but return the un-normalized color flow density matrix $\hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})$ in addition. When the relevant helicity basis is known, the latter can be used by the caller program to determine flow probabilities. (In reality, we assume the canonical basis and reduce the correlated out-state density to its diagonal immediately.) \end{enumerate} \end{itemize} @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Flavors: Particle properties} This module contains a type for holding the flavor code, and all functions that depend on the model, i.e., that determine particle properties. The PDG code is packed in a special [[flavor]] type. (This prohibits meaningless operations, and it allows for a different implementation, e.g., some non-PDG scheme internally, if appropiate at some point.) There are lots of further particle properties that depend on the model. Implementing a flyweight pattern, the associated field data object is to be stored in a central area, the [[flavor]] object just receives a pointer to this, so all queries can be delegated. <<[[flavors.f90]]>>= <> module flavors <> <> use io_units use diagnostics use physics_defs, only: UNDEFINED use physics_defs, only: INVALID use physics_defs, only: HADRON_REMNANT use physics_defs, only: HADRON_REMNANT_SINGLET use physics_defs, only: HADRON_REMNANT_TRIPLET use physics_defs, only: HADRON_REMNANT_OCTET use model_data use colors, only: color_t <> <> <> <> contains <> end module flavors @ %def flavors @ \subsection{The flavor type} The flavor type is an integer representing the PDG code, or undefined (zero). Negative codes represent antiflavors. They should be used only for particles which do have a distinct antiparticle. The [[hard_process]] flag can be set for particles that are participating in the hard interaction. The [[radiated]] flag can be set for particles that are the result of a beam-structure interaction (hadron beam remnant, ISR photon, etc.), not of the hard interaction itself. Further properties of the given flavor can be retrieved via the particle-data pointer, if it is associated. <>= public :: flavor_t <>= type :: flavor_t private integer :: f = UNDEFINED logical :: hard_process = .false. logical :: radiated = .false. type(field_data_t), pointer :: field_data => null () contains <> end type flavor_t @ %def flavor_t @ Initializer form. If the model is assigned, the procedure is impure, therefore we have to define a separate array version. Note: The pure elemental subroutines can't have an intent(out) CLASS argument (because of the potential for an impure finalizer in a type extension), so we stick to intent(inout) and (re)set all components explicitly. <>= generic :: init => & flavor_init_empty, & flavor_init, & flavor_init_field_data, & flavor_init_model, & flavor_init_model_alt, & flavor_init_name_model procedure, private :: flavor_init_empty procedure, private :: flavor_init procedure, private :: flavor_init_field_data procedure, private :: flavor_init_model procedure, private :: flavor_init_model_alt procedure, private :: flavor_init_name_model <>= elemental subroutine flavor_init_empty (flv) class(flavor_t), intent(inout) :: flv flv%f = UNDEFINED flv%hard_process = .false. flv%radiated = .false. flv%field_data => null () end subroutine flavor_init_empty elemental subroutine flavor_init (flv, f) class(flavor_t), intent(inout) :: flv integer, intent(in) :: f flv%f = f flv%hard_process = .false. flv%radiated = .false. flv%field_data => null () end subroutine flavor_init impure elemental subroutine flavor_init_field_data (flv, field_data) class(flavor_t), intent(inout) :: flv type(field_data_t), intent(in), target :: field_data flv%f = field_data%get_pdg () flv%hard_process = .false. flv%radiated = .false. flv%field_data => field_data end subroutine flavor_init_field_data impure elemental subroutine flavor_init_model (flv, f, model) class(flavor_t), intent(inout) :: flv integer, intent(in) :: f class(model_data_t), intent(in), target :: model flv%f = f flv%hard_process = .false. flv%radiated = .false. flv%field_data => model%get_field_ptr (f, check=.true.) end subroutine flavor_init_model impure elemental subroutine flavor_init_model_alt (flv, f, model, alt_model) class(flavor_t), intent(inout) :: flv integer, intent(in) :: f class(model_data_t), intent(in), target :: model, alt_model flv%f = f flv%hard_process = .false. flv%radiated = .false. flv%field_data => model%get_field_ptr (f, check=.false.) if (.not. associated (flv%field_data)) then flv%field_data => alt_model%get_field_ptr (f, check=.false.) if (.not. associated (flv%field_data)) then write (msg_buffer, "(A,1x,I0,1x,A,1x,A,1x,A,1x,A)") & "Particle with code", f, & "found neither in model", char (model%get_name ()), & "nor in model", char (alt_model%get_name ()) call msg_fatal () end if end if end subroutine flavor_init_model_alt impure elemental subroutine flavor_init_name_model (flv, name, model) class(flavor_t), intent(inout) :: flv type(string_t), intent(in) :: name class(model_data_t), intent(in), target :: model flv%f = model%get_pdg (name) flv%hard_process = .false. flv%radiated = .false. flv%field_data => model%get_field_ptr (name, check=.true.) end subroutine flavor_init_name_model @ %def flavor_init @ Set the [[radiated]] flag. <>= procedure :: tag_radiated => flavor_tag_radiated <>= elemental subroutine flavor_tag_radiated (flv) class(flavor_t), intent(inout) :: flv flv%radiated = .true. end subroutine flavor_tag_radiated @ %def flavor_tag_radiated @ Set the [[hard_process]] flag. <>= procedure :: tag_hard_process => flavor_tag_hard_process <>= elemental subroutine flavor_tag_hard_process (flv) class(flavor_t), intent(inout) :: flv flv%hard_process = .true. end subroutine flavor_tag_hard_process @ %def flavor_tag_hard_process @ Undefine the flavor state: <>= procedure :: undefine => flavor_undefine <>= elemental subroutine flavor_undefine (flv) class(flavor_t), intent(inout) :: flv flv%f = UNDEFINED flv%field_data => null () end subroutine flavor_undefine @ %def flavor_undefine @ Output: dense, no linebreak <>= procedure :: write => flavor_write <>= subroutine flavor_write (flv, unit) class(flavor_t), intent(in) :: flv integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (associated (flv%field_data)) then write (u, "(A)", advance="no") "f(" else write (u, "(A)", advance="no") "p(" end if write (u, "(I0)", advance="no") flv%f if (flv%radiated) then write (u, "('*')", advance="no") end if write (u, "(A)", advance="no") ")" end subroutine flavor_write @ %def flavor_write @ <>= public :: flavor_write_array <>= subroutine flavor_write_array (flv, unit) type(flavor_t), intent(in), dimension(:) :: flv integer, intent(in), optional :: unit integer :: u, i_flv u = given_output_unit (unit); if (u < 0) return do i_flv = 1, size (flv) call flv(i_flv)%write (u) if (i_flv /= size (flv)) write (u,"(A)", advance = "no") " / " end do write (u,"(A)") end subroutine flavor_write_array @ %def flavor_write_array @ Binary I/O. Currently, the model information is not written/read, so after reading the particle-data pointer is empty. <>= procedure :: write_raw => flavor_write_raw procedure :: read_raw => flavor_read_raw <>= subroutine flavor_write_raw (flv, u) class(flavor_t), intent(in) :: flv integer, intent(in) :: u write (u) flv%f write (u) flv%radiated end subroutine flavor_write_raw subroutine flavor_read_raw (flv, u, iostat) class(flavor_t), intent(out) :: flv integer, intent(in) :: u integer, intent(out), optional :: iostat read (u, iostat=iostat) flv%f if (present (iostat)) then if (iostat /= 0) return end if read (u, iostat=iostat) flv%radiated end subroutine flavor_read_raw @ %def flavor_write_raw flavor_read_raw @ \subsubsection{Assignment} Default assignment of flavor objects is possible, but cannot be used in pure procedures, because a pointer assignment is involved. Assign the particle pointer separately. This cannot be elemental, so we define a scalar and an array version explicitly. We refer to an array of flavors, not an array of models. <>= procedure :: set_model => flavor_set_model_single <>= impure elemental subroutine flavor_set_model_single (flv, model) class(flavor_t), intent(inout) :: flv class(model_data_t), intent(in), target :: model if (flv%f /= UNDEFINED) & flv%field_data => model%get_field_ptr (flv%f) end subroutine flavor_set_model_single @ %def flavor_set_model @ \subsubsection{Predicates} Return the definition status. By definition, the flavor object is defined if the flavor PDG code is nonzero. <>= procedure :: is_defined => flavor_is_defined <>= elemental function flavor_is_defined (flv) result (defined) class(flavor_t), intent(in) :: flv logical :: defined defined = flv%f /= UNDEFINED end function flavor_is_defined @ %def flavor_is_defined @ Check for valid flavor (including undefined). This is distinct from the [[is_defined]] status. Invalid flavor is actually a specific PDG code. <>= procedure :: is_valid => flavor_is_valid <>= elemental function flavor_is_valid (flv) result (valid) class(flavor_t), intent(in) :: flv logical :: valid valid = flv%f /= INVALID end function flavor_is_valid @ %def flavor_is_valid @ Return true if the particle-data pointer is associated. (Debugging aid) <>= procedure :: is_associated => flavor_is_associated <>= elemental function flavor_is_associated (flv) result (flag) class(flavor_t), intent(in) :: flv logical :: flag flag = associated (flv%field_data) end function flavor_is_associated @ %def flavor_is_associated @ Check the [[radiated]] flag. A radiated particle has a definite PDG flavor status, but it is actually a pseudoparticle (a beam remnant) which may be subject to fragmentation. <>= procedure :: is_radiated => flavor_is_radiated <>= elemental function flavor_is_radiated (flv) result (flag) class(flavor_t), intent(in) :: flv logical :: flag flag = flv%radiated end function flavor_is_radiated @ %def flavor_is_radiated @ Check the [[hard_process]] flag. A particle is tagged with this flag if it participates in the hard interaction and is not a beam remnant. <>= procedure :: is_hard_process => flavor_is_hard_process <>= elemental function flavor_is_hard_process (flv) result (flag) class(flavor_t), intent(in) :: flv logical :: flag flag = flv%hard_process end function flavor_is_hard_process @ %def flavor_is_hard_process @ \subsubsection{Accessing contents} With the exception of the PDG code, all particle property enquiries are delegated to the [[field_data]] pointer. If this is unassigned, some access function will crash. Return the flavor as an integer <>= procedure :: get_pdg => flavor_get_pdg <>= elemental function flavor_get_pdg (flv) result (f) integer :: f class(flavor_t), intent(in) :: flv f = flv%f end function flavor_get_pdg @ %def flavor_get_pdg @ Return the flavor of the antiparticle <>= procedure :: get_pdg_anti => flavor_get_pdg_anti <>= elemental function flavor_get_pdg_anti (flv) result (f) integer :: f class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flv%field_data%has_antiparticle ()) then f = -flv%f else f = flv%f end if else f = 0 end if end function flavor_get_pdg_anti @ %def flavor_get_pdg_anti @ Absolute value: <>= procedure :: get_pdg_abs => flavor_get_pdg_abs <>= elemental function flavor_get_pdg_abs (flv) result (f) integer :: f class(flavor_t), intent(in) :: flv f = abs (flv%f) end function flavor_get_pdg_abs @ %def flavor_get_pdg_abs @ Generic properties <>= procedure :: is_visible => flavor_is_visible procedure :: is_parton => flavor_is_parton procedure :: is_beam_remnant => flavor_is_beam_remnant procedure :: is_gauge => flavor_is_gauge procedure :: is_left_handed => flavor_is_left_handed procedure :: is_right_handed => flavor_is_right_handed procedure :: is_antiparticle => flavor_is_antiparticle procedure :: has_antiparticle => flavor_has_antiparticle procedure :: is_stable => flavor_is_stable procedure :: get_decays => flavor_get_decays procedure :: decays_isotropically => flavor_decays_isotropically procedure :: decays_diagonal => flavor_decays_diagonal procedure :: has_decay_helicity => flavor_has_decay_helicity procedure :: get_decay_helicity => flavor_get_decay_helicity procedure :: is_polarized => flavor_is_polarized <>= elemental function flavor_is_visible (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_visible () else flag = .false. end if end function flavor_is_visible elemental function flavor_is_parton (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_parton () else flag = .false. end if end function flavor_is_parton elemental function flavor_is_beam_remnant (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv select case (abs (flv%f)) case (HADRON_REMNANT, & HADRON_REMNANT_SINGLET, HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET) flag = .true. case default flag = .false. end select end function flavor_is_beam_remnant elemental function flavor_is_gauge (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_gauge () else flag = .false. end if end function flavor_is_gauge elemental function flavor_is_left_handed (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flv%f > 0) then flag = flv%field_data%is_left_handed () else flag = flv%field_data%is_right_handed () end if else flag = .false. end if end function flavor_is_left_handed elemental function flavor_is_right_handed (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flv%f > 0) then flag = flv%field_data%is_right_handed () else flag = flv%field_data%is_left_handed () end if else flag = .false. end if end function flavor_is_right_handed elemental function flavor_is_antiparticle (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv flag = flv%f < 0 end function flavor_is_antiparticle elemental function flavor_has_antiparticle (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%has_antiparticle () else flag = .false. end if end function flavor_has_antiparticle elemental function flavor_is_stable (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_stable (anti = flv%f < 0) else flag = .true. end if end function flavor_is_stable subroutine flavor_get_decays (flv, decay) class(flavor_t), intent(in) :: flv type(string_t), dimension(:), intent(out), allocatable :: decay logical :: anti anti = flv%f < 0 if (.not. flv%field_data%is_stable (anti)) then call flv%field_data%get_decays (decay, anti) end if end subroutine flavor_get_decays elemental function flavor_decays_isotropically (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%decays_isotropically (anti = flv%f < 0) else flag = .true. end if end function flavor_decays_isotropically elemental function flavor_decays_diagonal (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%decays_diagonal (anti = flv%f < 0) else flag = .true. end if end function flavor_decays_diagonal elemental function flavor_has_decay_helicity (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%has_decay_helicity (anti = flv%f < 0) else flag = .false. end if end function flavor_has_decay_helicity elemental function flavor_get_decay_helicity (flv) result (hel) integer :: hel class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then hel = flv%field_data%decay_helicity (anti = flv%f < 0) else hel = 0 end if end function flavor_get_decay_helicity elemental function flavor_is_polarized (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_polarized (anti = flv%f < 0) else flag = .false. end if end function flavor_is_polarized @ %def flavor_is_visible @ %def flavor_is_parton @ %def flavor_is_beam_remnant @ %def flavor_is_gauge @ %def flavor_is_left_handed @ %def flavor_is_right_handed @ %def flavor_is_antiparticle @ %def flavor_has_antiparticle @ %def flavor_is_stable @ %def flavor_get_decays @ %def flavor_decays_isotropically @ %def flavor_decays_diagonal @ %def flavor_has_decays_helicity @ %def flavor_get_decay_helicity @ %def flavor_is_polarized @ Names: <>= procedure :: get_name => flavor_get_name procedure :: get_tex_name => flavor_get_tex_name <>= elemental function flavor_get_name (flv) result (name) type(string_t) :: name class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then name = flv%field_data%get_name (flv%f < 0) else name = "?" end if end function flavor_get_name elemental function flavor_get_tex_name (flv) result (name) type(string_t) :: name class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then name = flv%field_data%get_tex_name (flv%f < 0) else name = "?" end if end function flavor_get_tex_name @ %def flavor_get_name flavor_get_tex_name <>= procedure :: get_spin_type => flavor_get_spin_type procedure :: get_multiplicity => flavor_get_multiplicity procedure :: get_isospin_type => flavor_get_isospin_type procedure :: get_charge_type => flavor_get_charge_type procedure :: get_color_type => flavor_get_color_type <>= elemental function flavor_get_spin_type (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then type = flv%field_data%get_spin_type () else type = 1 end if end function flavor_get_spin_type elemental function flavor_get_multiplicity (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then type = flv%field_data%get_multiplicity () else type = 1 end if end function flavor_get_multiplicity elemental function flavor_get_isospin_type (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then type = flv%field_data%get_isospin_type () else type = 1 end if end function flavor_get_isospin_type elemental function flavor_get_charge_type (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then type = flv%field_data%get_charge_type () else type = 1 end if end function flavor_get_charge_type elemental function flavor_get_color_type (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flavor_is_antiparticle (flv)) then type = - flv%field_data%get_color_type () else type = flv%field_data%get_color_type () end if select case (type) case (-1,-8); type = abs (type) end select else type = 1 end if end function flavor_get_color_type @ %def flavor_get_spin_type @ %def flavor_get_multiplicity @ %def flavor_get_isospin_type @ %def flavor_get_charge_type @ %def flavor_get_color_type @ These functions return real values: <>= procedure :: get_charge => flavor_get_charge procedure :: get_mass => flavor_get_mass procedure :: get_width => flavor_get_width procedure :: get_isospin => flavor_get_isospin <>= elemental function flavor_get_charge (flv) result (charge) real(default) :: charge class(flavor_t), intent(in) :: flv integer :: charge_type if (associated (flv%field_data)) then charge_type = flv%get_charge_type () if (charge_type == 0 .or. charge_type == 1) then charge = 0 else if (flavor_is_antiparticle (flv)) then charge = - flv%field_data%get_charge () else charge = flv%field_data%get_charge () end if end if else charge = 0 end if end function flavor_get_charge elemental function flavor_get_mass (flv) result (mass) real(default) :: mass class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then mass = flv%field_data%get_mass () else mass = 0 end if end function flavor_get_mass elemental function flavor_get_width (flv) result (width) real(default) :: width class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then width = flv%field_data%get_width () else width = 0 end if end function flavor_get_width elemental function flavor_get_isospin (flv) result (isospin) real(default) :: isospin class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flavor_is_antiparticle (flv)) then isospin = - flv%field_data%get_isospin () else isospin = flv%field_data%get_isospin () end if else isospin = 0 end if end function flavor_get_isospin @ %def flavor_get_charge flavor_get_mass flavor_get_width @ %def flavor_get_isospin @ \subsubsection{Comparisons} If one of the flavors is undefined, the other defined, they match. <>= generic :: operator(.match.) => flavor_match generic :: operator(==) => flavor_eq generic :: operator(/=) => flavor_neq procedure, private :: flavor_match procedure, private :: flavor_eq procedure, private :: flavor_neq @ %def .match. == /= <>= elemental function flavor_match (flv1, flv2) result (eq) logical :: eq class(flavor_t), intent(in) :: flv1, flv2 if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then eq = flv1%f == flv2%f else eq = .true. end if end function flavor_match elemental function flavor_eq (flv1, flv2) result (eq) logical :: eq class(flavor_t), intent(in) :: flv1, flv2 if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then eq = flv1%f == flv2%f else if (flv1%f == UNDEFINED .and. flv2%f == UNDEFINED) then eq = .true. else eq = .false. end if end function flavor_eq @ %def flavor_match flavor_eq <>= elemental function flavor_neq (flv1, flv2) result (neq) logical :: neq class(flavor_t), intent(in) :: flv1, flv2 if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then neq = flv1%f /= flv2%f else if (flv1%f == UNDEFINED .and. flv2%f == UNDEFINED) then neq = .false. else neq = .true. end if end function flavor_neq @ %def flavor_neq @ \subsubsection{Tools} Merge two flavor indices. This works only if both are equal or either one is undefined, because we have no off-diagonal flavor entries. Otherwise, generate an invalid flavor. We cannot use elemental procedures because of the pointer component. <>= public :: operator(.merge.) <>= interface operator(.merge.) module procedure merge_flavors0 module procedure merge_flavors1 end interface @ %def .merge. <>= function merge_flavors0 (flv1, flv2) result (flv) type(flavor_t) :: flv type(flavor_t), intent(in) :: flv1, flv2 if (flavor_is_defined (flv1) .and. flavor_is_defined (flv2)) then if (flv1 == flv2) then flv = flv1 else flv%f = INVALID end if else if (flavor_is_defined (flv1)) then flv = flv1 else if (flavor_is_defined (flv2)) then flv = flv2 end if end function merge_flavors0 function merge_flavors1 (flv1, flv2) result (flv) type(flavor_t), dimension(:), intent(in) :: flv1, flv2 type(flavor_t), dimension(size(flv1)) :: flv integer :: i do i = 1, size (flv1) flv(i) = flv1(i) .merge. flv2(i) end do end function merge_flavors1 @ %def merge_flavors @ Generate consecutive color indices for a given flavor. The indices are counted starting with the stored value of c, so new indices are created each time this (impure) function is called. The counter can be reset by the optional argument [[c_seed]] if desired. The optional flag [[reverse]] is used only for octets. If set, the color and anticolor entries of the octet particle are exchanged. <>= public :: color_from_flavor <>= interface color_from_flavor module procedure color_from_flavor0 module procedure color_from_flavor1 end interface <>= function color_from_flavor0 (flv, c_seed, reverse) result (col) type(color_t) :: col type(flavor_t), intent(in) :: flv integer, intent(in), optional :: c_seed logical, intent(in), optional :: reverse integer, save :: c = 1 logical :: rev if (present (c_seed)) c = c_seed rev = .false.; if (present (reverse)) rev = reverse select case (flavor_get_color_type (flv)) case (1) call col%init () case (3) call col%init ([c]); c = c + 1 case (-3) call col%init ([-c]); c = c + 1 case (8) if (rev) then call col%init ([c+1, -c]); c = c + 2 else call col%init ([c, -(c+1)]); c = c + 2 end if end select end function color_from_flavor0 function color_from_flavor1 (flv, c_seed, reverse) result (col) type(flavor_t), dimension(:), intent(in) :: flv integer, intent(in), optional :: c_seed logical, intent(in), optional :: reverse type(color_t), dimension(size(flv)) :: col integer :: i col(1) = color_from_flavor0 (flv(1), c_seed, reverse) do i = 2, size (flv) col(i) = color_from_flavor0 (flv(i), reverse=reverse) end do end function color_from_flavor1 @ %def color_from_flavor @ This procedure returns the flavor object for the antiparticle. The antiparticle code may either be the same code or its negative. <>= procedure :: anti => flavor_anti <>= function flavor_anti (flv) result (aflv) type(flavor_t) :: aflv class(flavor_t), intent(in) :: flv if (flavor_has_antiparticle (flv)) then aflv%f = - flv%f else aflv%f = flv%f end if aflv%field_data => flv%field_data end function flavor_anti @ %def flavor_anti @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Quantum numbers} This module collects helicity, color, and flavor in a single type and defines procedures <<[[quantum_numbers.f90]]>>= <> module quantum_numbers use io_units use model_data use helicities use colors use flavors <> <> <> <> contains <> end module quantum_numbers @ %def quantum_numbers @ \subsection{The quantum number type} <>= public :: quantum_numbers_t <>= type :: quantum_numbers_t private type(flavor_t) :: f type(color_t) :: c type(helicity_t) :: h integer :: sub = 0 contains <> end type quantum_numbers_t @ %def quantum_number_t @ Define quantum numbers: Initializer form. All arguments may be present or absent. Some elemental initializers are impure because they set the [[flv]] component. This implies transfer of a pointer behind the scenes. <>= generic :: init => & quantum_numbers_init_f, & quantum_numbers_init_c, & quantum_numbers_init_h, & quantum_numbers_init_fc, & quantum_numbers_init_fh, & quantum_numbers_init_ch, & quantum_numbers_init_fch, & quantum_numbers_init_fs, & quantum_numbers_init_fhs, & quantum_numbers_init_fcs, & quantum_numbers_init_fhcs procedure, private :: quantum_numbers_init_f procedure, private :: quantum_numbers_init_c procedure, private :: quantum_numbers_init_h procedure, private :: quantum_numbers_init_fc procedure, private :: quantum_numbers_init_fh procedure, private :: quantum_numbers_init_ch procedure, private :: quantum_numbers_init_fch procedure, private :: quantum_numbers_init_fs procedure, private :: quantum_numbers_init_fhs procedure, private :: quantum_numbers_init_fcs procedure, private :: quantum_numbers_init_fhcs <>= impure elemental subroutine quantum_numbers_init_f (qn, flv) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv qn%f = flv call qn%c%undefine () call qn%h%undefine () qn%sub = 0 end subroutine quantum_numbers_init_f impure elemental subroutine quantum_numbers_init_c (qn, col) class(quantum_numbers_t), intent(out) :: qn type(color_t), intent(in) :: col call qn%f%undefine () qn%c = col call qn%h%undefine () qn%sub = 0 end subroutine quantum_numbers_init_c impure elemental subroutine quantum_numbers_init_h (qn, hel) class(quantum_numbers_t), intent(out) :: qn type(helicity_t), intent(in) :: hel call qn%f%undefine () call qn%c%undefine () qn%h = hel qn%sub = 0 end subroutine quantum_numbers_init_h impure elemental subroutine quantum_numbers_init_fc (qn, flv, col) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(color_t), intent(in) :: col qn%f = flv qn%c = col call qn%h%undefine () qn%sub = 0 end subroutine quantum_numbers_init_fc impure elemental subroutine quantum_numbers_init_fh (qn, flv, hel) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(helicity_t), intent(in) :: hel qn%f = flv call qn%c%undefine () qn%h = hel qn%sub = 0 end subroutine quantum_numbers_init_fh impure elemental subroutine quantum_numbers_init_ch (qn, col, hel) class(quantum_numbers_t), intent(out) :: qn type(color_t), intent(in) :: col type(helicity_t), intent(in) :: hel call qn%f%undefine () qn%c = col qn%h = hel qn%sub = 0 end subroutine quantum_numbers_init_ch impure elemental subroutine quantum_numbers_init_fch (qn, flv, col, hel) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(color_t), intent(in) :: col type(helicity_t), intent(in) :: hel qn%f = flv qn%c = col qn%h = hel qn%sub = 0 end subroutine quantum_numbers_init_fch impure elemental subroutine quantum_numbers_init_fs (qn, flv, sub) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv integer, intent(in) :: sub qn%f = flv; qn%sub = sub end subroutine quantum_numbers_init_fs impure elemental subroutine quantum_numbers_init_fhs (qn, flv, hel, sub) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(helicity_t), intent(in) :: hel integer, intent(in) :: sub qn%f = flv; qn%h = hel; qn%sub = sub end subroutine quantum_numbers_init_fhs impure elemental subroutine quantum_numbers_init_fcs (qn, flv, col, sub) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(color_t), intent(in) :: col integer, intent(in) :: sub qn%f = flv; qn%c = col; qn%sub = sub end subroutine quantum_numbers_init_fcs impure elemental subroutine quantum_numbers_init_fhcs (qn, flv, hel, col, sub) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(helicity_t), intent(in) :: hel type(color_t), intent(in) :: col integer, intent(in) :: sub qn%f = flv; qn%h = hel; qn%c = col; qn%sub = sub end subroutine quantum_numbers_init_fhcs @ %def quantum_numbers_init @ \subsection{I/O} Write the quantum numbers in condensed form, enclosed by square brackets. Color is written only if nontrivial. For convenience, introduce also an array version. If the [[col_verbose]] option is set, show the quantum number color also if it is zero, but defined. Otherwise, suppress zero color. <>= public :: quantum_numbers_write <>= procedure :: write => quantum_numbers_write_single <>= interface quantum_numbers_write module procedure quantum_numbers_write_single module procedure quantum_numbers_write_array end interface <>= subroutine quantum_numbers_write_single (qn, unit, col_verbose) class(quantum_numbers_t), intent(in) :: qn integer, intent(in), optional :: unit logical, intent(in), optional :: col_verbose integer :: u logical :: col_verb u = given_output_unit (unit); if (u < 0) return col_verb = .false.; if (present (col_verbose)) col_verb = col_verbose write (u, "(A)", advance = "no") "[" if (qn%f%is_defined ()) then call qn%f%write (u) if (qn%c%is_nonzero () .or. qn%h%is_defined ()) & write (u, "(1x)", advance = "no") end if if (col_verb) then if (qn%c%is_defined () .or. qn%c%is_ghost ()) then call color_write (qn%c, u) if (qn%h%is_defined ()) write (u, "(1x)", advance = "no") end if else if (qn%c%is_nonzero () .or. qn%c%is_ghost ()) then call color_write (qn%c, u) if (qn%h%is_defined ()) write (u, "(1x)", advance = "no") end if end if if (qn%h%is_defined ()) then call qn%h%write (u) end if if (qn%sub > 0) & write (u, "(A,I0)", advance = "no") " SUB = ", qn%sub write (u, "(A)", advance="no") "]" end subroutine quantum_numbers_write_single subroutine quantum_numbers_write_array (qn, unit, col_verbose) type(quantum_numbers_t), dimension(:), intent(in) :: qn integer, intent(in), optional :: unit logical, intent(in), optional :: col_verbose integer :: i integer :: u logical :: col_verb u = given_output_unit (unit); if (u < 0) return col_verb = .false.; if (present (col_verbose)) col_verb = col_verbose write (u, "(A)", advance="no") "[" do i = 1, size (qn) if (i > 1) write (u, "(A)", advance="no") " / " if (qn(i)%f%is_defined ()) then call qn(i)%f%write (u) if (qn(i)%c%is_nonzero () .or. qn(i)%h%is_defined ()) & write (u, "(1x)", advance="no") end if if (col_verb) then if (qn(i)%c%is_defined () .or. qn(i)%c%is_ghost ()) then call color_write (qn(i)%c, u) if (qn(i)%h%is_defined ()) write (u, "(1x)", advance="no") end if else if (qn(i)%c%is_nonzero () .or. qn(i)%c%is_ghost ()) then call color_write (qn(i)%c, u) if (qn(i)%h%is_defined ()) write (u, "(1x)", advance="no") end if end if if (qn(i)%h%is_defined ()) then call qn(i)%h%write (u) end if if (qn(i)%sub > 0) & write (u, "(A,I2)", advance = "no") " SUB = ", qn(i)%sub end do write (u, "(A)", advance = "no") "]" end subroutine quantum_numbers_write_array @ %def quantum_numbers_write @ Binary I/O. <>= procedure :: write_raw => quantum_numbers_write_raw procedure :: read_raw => quantum_numbers_read_raw <>= subroutine quantum_numbers_write_raw (qn, u) class(quantum_numbers_t), intent(in) :: qn integer, intent(in) :: u call qn%f%write_raw (u) call qn%c%write_raw (u) call qn%h%write_raw (u) end subroutine quantum_numbers_write_raw subroutine quantum_numbers_read_raw (qn, u, iostat) class(quantum_numbers_t), intent(out) :: qn integer, intent(in) :: u integer, intent(out), optional :: iostat call qn%f%read_raw (u, iostat=iostat) call qn%c%read_raw (u, iostat=iostat) call qn%h%read_raw (u, iostat=iostat) end subroutine quantum_numbers_read_raw @ %def quantum_numbers_write_raw quantum_numbers_read_raw @ \subsection{Accessing contents} Color and helicity can be done by elemental functions. Flavor needs impure elemental. We export also the functions directly, this allows us to avoid temporaries in some places. <>= public :: quantum_numbers_get_flavor public :: quantum_numbers_get_color public :: quantum_numbers_get_helicity <>= procedure :: get_flavor => quantum_numbers_get_flavor procedure :: get_color => quantum_numbers_get_color procedure :: get_helicity => quantum_numbers_get_helicity procedure :: get_sub => quantum_numbers_get_sub <>= impure elemental function quantum_numbers_get_flavor (qn) result (flv) type(flavor_t) :: flv class(quantum_numbers_t), intent(in) :: qn flv = qn%f end function quantum_numbers_get_flavor elemental function quantum_numbers_get_color (qn) result (col) type(color_t) :: col class(quantum_numbers_t), intent(in) :: qn col = qn%c end function quantum_numbers_get_color elemental function quantum_numbers_get_helicity (qn) result (hel) type(helicity_t) :: hel class(quantum_numbers_t), intent(in) :: qn hel = qn%h end function quantum_numbers_get_helicity elemental function quantum_numbers_get_sub (qn) result (sub) integer :: sub class(quantum_numbers_t), intent(in) :: qn sub = qn%sub end function quantum_numbers_get_sub @ %def quantum_numbers_get_flavor @ %def quantum_numbers_get_color @ %def quantum_numbers_get_helicity @ %def quantum_numbers_get_sub @ This just resets the ghost property of the color part: <>= procedure :: set_color_ghost => quantum_numbers_set_color_ghost <>= elemental subroutine quantum_numbers_set_color_ghost (qn, ghost) class(quantum_numbers_t), intent(inout) :: qn logical, intent(in) :: ghost call qn%c%set_ghost (ghost) end subroutine quantum_numbers_set_color_ghost @ %def quantum_numbers_set_color_ghost @ Assign a model to the flavor part of quantum numbers. <>= procedure :: set_model => quantum_numbers_set_model <>= impure elemental subroutine quantum_numbers_set_model (qn, model) class(quantum_numbers_t), intent(inout) :: qn class(model_data_t), intent(in), target :: model call qn%f%set_model (model) end subroutine quantum_numbers_set_model @ %def quantum_numbers_set_model @ Set the [[radiated]] flag for the flavor component. <>= procedure :: tag_radiated => quantum_numbers_tag_radiated <>= elemental subroutine quantum_numbers_tag_radiated (qn) class(quantum_numbers_t), intent(inout) :: qn call qn%f%tag_radiated () end subroutine quantum_numbers_tag_radiated @ %def quantum_numbers_tag_radiated @ Set the [[hard_process]] flag for the flavor component. <>= procedure :: tag_hard_process => quantum_numbers_tag_hard_process <>= elemental subroutine quantum_numbers_tag_hard_process (qn) class(quantum_numbers_t), intent(inout) :: qn call qn%f%tag_hard_process () end subroutine quantum_numbers_tag_hard_process @ %def quantum_numbers_tag_hard_process @ <>= procedure :: set_subtraction_index => quantum_numbers_set_subtraction_index <>= elemental subroutine quantum_numbers_set_subtraction_index (qn, i) class(quantum_numbers_t), intent(inout) :: qn integer, intent(in) :: i qn%sub = i end subroutine quantum_numbers_set_subtraction_index @ %def quantum_numbers_set_subtraction_index @ <>= procedure :: get_subtraction_index => quantum_numbers_get_subtraction_index <>= elemental function quantum_numbers_get_subtraction_index (qn) result (sub) integer :: sub class(quantum_numbers_t), intent(in) :: qn sub = qn%sub end function quantum_numbers_get_subtraction_index @ %def quantum_numbers_get_subtraction_index @ This is a convenience function: return the color type for the flavor (array). <>= procedure :: get_color_type => quantum_numbers_get_color_type <>= elemental function quantum_numbers_get_color_type (qn) result (color_type) integer :: color_type class(quantum_numbers_t), intent(in) :: qn color_type = qn%f%get_color_type () end function quantum_numbers_get_color_type @ %def quantum_numbers_get_color_type @ \subsection{Predicates} Check if the flavor index is valid (including UNDEFINED). <>= procedure :: are_valid => quantum_numbers_are_valid <>= elemental function quantum_numbers_are_valid (qn) result (valid) logical :: valid class(quantum_numbers_t), intent(in) :: qn valid = qn%f%is_valid () end function quantum_numbers_are_valid @ %def quantum_numbers_are_valid @ Check if the flavor part has its particle-data pointer associated (debugging aid). <>= procedure :: are_associated => quantum_numbers_are_associated <>= elemental function quantum_numbers_are_associated (qn) result (flag) logical :: flag class(quantum_numbers_t), intent(in) :: qn flag = qn%f%is_associated () end function quantum_numbers_are_associated @ %def quantum_numbers_are_associated @ Check if the helicity and color quantum numbers are diagonal. (Unpolarized/colorless also counts as diagonal.) Flavor is diagonal by definition. <>= procedure :: are_diagonal => quantum_numbers_are_diagonal <>= elemental function quantum_numbers_are_diagonal (qn) result (diagonal) logical :: diagonal class(quantum_numbers_t), intent(in) :: qn diagonal = qn%h%is_diagonal () .and. qn%c%is_diagonal () end function quantum_numbers_are_diagonal @ %def quantum_numbers_are_diagonal @ Check if the color part has the ghost property. <>= procedure :: is_color_ghost => quantum_numbers_is_color_ghost <>= elemental function quantum_numbers_is_color_ghost (qn) result (ghost) logical :: ghost class(quantum_numbers_t), intent(in) :: qn ghost = qn%c%is_ghost () end function quantum_numbers_is_color_ghost @ %def quantum_numbers_is_color_ghost @ Check if the flavor participates in the hard interaction. <>= procedure :: are_hard_process => quantum_numbers_are_hard_process <>= elemental function quantum_numbers_are_hard_process (qn) result (hard_process) logical :: hard_process class(quantum_numbers_t), intent(in) :: qn hard_process = qn%f%is_hard_process () end function quantum_numbers_are_hard_process @ %def quantum_numbers_are_hard_process @ \subsection{Comparisons} Matching and equality is derived from the individual quantum numbers. The variant [[fhmatch]] matches only flavor and helicity. The variant [[dhmatch]] matches only diagonal helicity, if the matching helicity is undefined. <>= public :: quantum_numbers_eq_wo_sub <>= generic :: operator(.match.) => quantum_numbers_match generic :: operator(.fmatch.) => quantum_numbers_match_f generic :: operator(.hmatch.) => quantum_numbers_match_h generic :: operator(.fhmatch.) => quantum_numbers_match_fh generic :: operator(.dhmatch.) => quantum_numbers_match_hel_diag generic :: operator(==) => quantum_numbers_eq generic :: operator(/=) => quantum_numbers_neq procedure, private :: quantum_numbers_match procedure, private :: quantum_numbers_match_f procedure, private :: quantum_numbers_match_h procedure, private :: quantum_numbers_match_fh procedure, private :: quantum_numbers_match_hel_diag procedure, private :: quantum_numbers_eq procedure, private :: quantum_numbers_neq @ %def .match. == /= <>= elemental function quantum_numbers_match (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%f .match. qn2%f) .and. & (qn1%c .match. qn2%c) .and. & (qn1%h .match. qn2%h) end function quantum_numbers_match elemental function quantum_numbers_match_f (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%f .match. qn2%f) end function quantum_numbers_match_f elemental function quantum_numbers_match_h (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%h .match. qn2%h) end function quantum_numbers_match_h elemental function quantum_numbers_match_fh (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%f .match. qn2%f) .and. & (qn1%h .match. qn2%h) end function quantum_numbers_match_fh elemental function quantum_numbers_match_hel_diag (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%f .match. qn2%f) .and. & (qn1%c .match. qn2%c) .and. & (qn1%h .dmatch. qn2%h) end function quantum_numbers_match_hel_diag elemental function quantum_numbers_eq_wo_sub (qn1, qn2) result (eq) logical :: eq type(quantum_numbers_t), intent(in) :: qn1, qn2 eq = (qn1%f == qn2%f) .and. & (qn1%c == qn2%c) .and. & (qn1%h == qn2%h) end function quantum_numbers_eq_wo_sub elemental function quantum_numbers_eq (qn1, qn2) result (eq) logical :: eq class(quantum_numbers_t), intent(in) :: qn1, qn2 eq = (qn1%f == qn2%f) .and. & (qn1%c == qn2%c) .and. & (qn1%h == qn2%h) .and. & (qn1%sub == qn2%sub) end function quantum_numbers_eq elemental function quantum_numbers_neq (qn1, qn2) result (neq) logical :: neq class(quantum_numbers_t), intent(in) :: qn1, qn2 neq = (qn1%f /= qn2%f) .or. & (qn1%c /= qn2%c) .or. & (qn1%h /= qn2%h) .or. & (qn1%sub /= qn2%sub) end function quantum_numbers_neq @ %def quantum_numbers_match @ %def quantum_numbers_eq @ %def quantum_numbers_neq <>= public :: assignment(=) <>= interface assignment(=) module procedure quantum_numbers_assign end interface <>= subroutine quantum_numbers_assign (qn_out, qn_in) type(quantum_numbers_t), intent(out) :: qn_out type(quantum_numbers_t), intent(in) :: qn_in qn_out%f = qn_in%f qn_out%c = qn_in%c qn_out%h = qn_in%h qn_out%sub = qn_in%sub end subroutine quantum_numbers_assign @ %def quantum_numbers_assign @ Two sets of quantum numbers are compatible if the individual quantum numbers are compatible, depending on the mask. Flavor has to match, regardless of the flavor mask. If the color flag is set, color is compatible if the ghost property is identical. If the color flag is unset, color has to be identical. I.e., if the flag is set, the color amplitudes can interfere. If it is not set, they must be identical, and there must be no ghost. The latter property is used for expanding physical color flows. Helicity is compatible if the mask is unset, otherwise it has to match. This determines if two amplitudes can be multiplied (no mask) or traced (mask). <>= public :: quantum_numbers_are_compatible <>= elemental function quantum_numbers_are_compatible (qn1, qn2, mask) & result (flag) logical :: flag type(quantum_numbers_t), intent(in) :: qn1, qn2 type(quantum_numbers_mask_t), intent(in) :: mask if (mask%h .or. mask%hd) then flag = (qn1%f .match. qn2%f) .and. (qn1%h .match. qn2%h) else flag = (qn1%f .match. qn2%f) end if if (mask%c) then flag = flag .and. (qn1%c%is_ghost () .eqv. qn2%c%is_ghost ()) else flag = flag .and. & .not. (qn1%c%is_ghost () .or. qn2%c%is_ghost ()) .and. & (qn1%c == qn2%c) end if end function quantum_numbers_are_compatible @ %def quantum_numbers_are_compatible @ This is the analog for a single quantum-number set. We just check for color ghosts; they are excluded if the color mask is unset (color-flow expansion). <>= public :: quantum_numbers_are_physical <>= elemental function quantum_numbers_are_physical (qn, mask) result (flag) logical :: flag type(quantum_numbers_t), intent(in) :: qn type(quantum_numbers_mask_t), intent(in) :: mask if (mask%c) then flag = .true. else flag = .not. qn%c%is_ghost () end if end function quantum_numbers_are_physical @ %def quantum_numbers_are_physical @ \subsection{Operations} Inherited from the color component: reassign color indices in canonical order. <>= public :: quantum_numbers_canonicalize_color <>= subroutine quantum_numbers_canonicalize_color (qn) type(quantum_numbers_t), dimension(:), intent(inout) :: qn call color_canonicalize (qn%c) end subroutine quantum_numbers_canonicalize_color @ %def quantum_numbers_canonicalize_color @ Inherited from the color component: make a color map for two matching quantum-number arrays. <>= public :: make_color_map <>= interface make_color_map module procedure quantum_numbers_make_color_map end interface make_color_map <>= subroutine quantum_numbers_make_color_map (map, qn1, qn2) integer, dimension(:,:), intent(out), allocatable :: map type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2 call make_color_map (map, qn1%c, qn2%c) end subroutine quantum_numbers_make_color_map @ %def make_color_map @ Inherited from the color component: translate the color part using a color-map array <>= public :: quantum_numbers_translate_color <>= interface quantum_numbers_translate_color module procedure quantum_numbers_translate_color0 module procedure quantum_numbers_translate_color1 end interface <>= subroutine quantum_numbers_translate_color0 (qn, map, offset) type(quantum_numbers_t), intent(inout) :: qn integer, dimension(:,:), intent(in) :: map integer, intent(in), optional :: offset call color_translate (qn%c, map, offset) end subroutine quantum_numbers_translate_color0 subroutine quantum_numbers_translate_color1 (qn, map, offset) type(quantum_numbers_t), dimension(:), intent(inout) :: qn integer, dimension(:,:), intent(in) :: map integer, intent(in), optional :: offset call color_translate (qn%c, map, offset) end subroutine quantum_numbers_translate_color1 @ %def quantum_numbers_translate_color @ Inherited from the color component: return the color index with highest absolute value. Since the algorithm is not elemental, we keep the separate procedures for different array rank. <>= public :: quantum_numbers_get_max_color_value <>= interface quantum_numbers_get_max_color_value module procedure quantum_numbers_get_max_color_value0 module procedure quantum_numbers_get_max_color_value1 module procedure quantum_numbers_get_max_color_value2 end interface <>= pure function quantum_numbers_get_max_color_value0 (qn) result (cmax) integer :: cmax type(quantum_numbers_t), intent(in) :: qn cmax = color_get_max_value (qn%c) end function quantum_numbers_get_max_color_value0 pure function quantum_numbers_get_max_color_value1 (qn) result (cmax) integer :: cmax type(quantum_numbers_t), dimension(:), intent(in) :: qn cmax = color_get_max_value (qn%c) end function quantum_numbers_get_max_color_value1 pure function quantum_numbers_get_max_color_value2 (qn) result (cmax) integer :: cmax type(quantum_numbers_t), dimension(:,:), intent(in) :: qn cmax = color_get_max_value (qn%c) end function quantum_numbers_get_max_color_value2 @ Inherited from the color component: add an offset to the indices of the color part <>= procedure :: add_color_offset => quantum_numbers_add_color_offset <>= elemental subroutine quantum_numbers_add_color_offset (qn, offset) class(quantum_numbers_t), intent(inout) :: qn integer, intent(in) :: offset call qn%c%add_offset (offset) end subroutine quantum_numbers_add_color_offset @ %def quantum_numbers_add_color_offset @ Given a quantum number array, return all possible color contractions, leaving the other quantum numbers intact. <>= public :: quantum_number_array_make_color_contractions <>= subroutine quantum_number_array_make_color_contractions (qn_in, qn_out) type(quantum_numbers_t), dimension(:), intent(in) :: qn_in type(quantum_numbers_t), dimension(:,:), intent(out), allocatable :: qn_out type(color_t), dimension(:,:), allocatable :: col integer :: i call color_array_make_contractions (qn_in%c, col) allocate (qn_out (size (col, 1), size (col, 2))) do i = 1, size (qn_out, 2) qn_out(:,i)%f = qn_in%f qn_out(:,i)%c = col(:,i) qn_out(:,i)%h = qn_in%h end do end subroutine quantum_number_array_make_color_contractions @ %def quantum_number_array_make_color_contractions @ Inherited from the color component: invert the color, switching particle/antiparticle. <>= procedure :: invert_color => quantum_numbers_invert_color <>= elemental subroutine quantum_numbers_invert_color (qn) class(quantum_numbers_t), intent(inout) :: qn call qn%c%invert () end subroutine quantum_numbers_invert_color @ %def quantum_numbers_invert_color @ Flip helicity. <>= procedure :: flip_helicity => quantum_numbers_flip_helicity <>= elemental subroutine quantum_numbers_flip_helicity (qn) class(quantum_numbers_t), intent(inout) :: qn call qn%h%flip () end subroutine quantum_numbers_flip_helicity @ %def quantum_numbers_flip_helicity @ Merge two quantum number sets: for each entry, if both are defined, combine them to an off-diagonal entry (meaningful only if the input was diagonal). If either entry is undefined, take the defined one. For flavor, off-diagonal entries are invalid, so both flavors must be equal, otherwise an invalid flavor is inserted. <>= public :: operator(.merge.) <>= interface operator(.merge.) module procedure merge_quantum_numbers0 module procedure merge_quantum_numbers1 end interface <>= function merge_quantum_numbers0 (qn1, qn2) result (qn3) type(quantum_numbers_t) :: qn3 type(quantum_numbers_t), intent(in) :: qn1, qn2 qn3%f = qn1%f .merge. qn2%f qn3%c = qn1%c .merge. qn2%c qn3%h = qn1%h .merge. qn2%h qn3%sub = merge_subtraction_index (qn1%sub, qn2%sub) end function merge_quantum_numbers0 function merge_quantum_numbers1 (qn1, qn2) result (qn3) type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2 type(quantum_numbers_t), dimension(size(qn1)) :: qn3 qn3%f = qn1%f .merge. qn2%f qn3%c = qn1%c .merge. qn2%c qn3%h = qn1%h .merge. qn2%h qn3%sub = merge_subtraction_index (qn1%sub, qn2%sub) end function merge_quantum_numbers1 @ %def merge_quantum_numbers @ <>= elemental function merge_subtraction_index (sub1, sub2) result (sub3) integer :: sub3 integer, intent(in) :: sub1, sub2 if (sub1 > 0 .and. sub2 > 0) then if (sub1 == sub2) then sub3 = sub1 else sub3 = 0 end if else if (sub1 > 0) then sub3 = sub1 else if (sub2 > 0) then sub3 = sub2 else sub3 = 0 end if end function merge_subtraction_index @ %def merge_subtraction_index @ \subsection{The quantum number mask} The quantum numbers mask is true for quantum numbers that should be ignored or summed over. The three mandatory entries correspond to flavor, color, and helicity, respectively. There is an additional entry [[cg]]: If false, the color-ghosts property should be kept even if color is ignored. This is relevant only if [[c]] is set, otherwise it is always false. The flag [[hd]] tells that only diagonal entries in helicity should be kept. If [[h]] is set, [[hd]] is irrelevant and will be kept [[.false.]] <>= public :: quantum_numbers_mask_t <>= type :: quantum_numbers_mask_t private logical :: f = .false. logical :: c = .false. logical :: cg = .false. logical :: h = .false. logical :: hd = .false. integer :: sub = 0 contains <> end type quantum_numbers_mask_t @ %def quantum_number_t @ Define a quantum number mask: Constructor form <>= public :: quantum_numbers_mask <>= elemental function quantum_numbers_mask & (mask_f, mask_c, mask_h, mask_cg, mask_hd) result (mask) type(quantum_numbers_mask_t) :: mask logical, intent(in) :: mask_f, mask_c, mask_h logical, intent(in), optional :: mask_cg logical, intent(in), optional :: mask_hd call quantum_numbers_mask_init & (mask, mask_f, mask_c, mask_h, mask_cg, mask_hd) end function quantum_numbers_mask @ %def new_quantum_numbers_mask @ Define quantum numbers: Initializer form <>= procedure :: init => quantum_numbers_mask_init <>= elemental subroutine quantum_numbers_mask_init & (mask, mask_f, mask_c, mask_h, mask_cg, mask_hd) class(quantum_numbers_mask_t), intent(inout) :: mask logical, intent(in) :: mask_f, mask_c, mask_h logical, intent(in), optional :: mask_cg, mask_hd mask%f = mask_f mask%c = mask_c mask%h = mask_h mask%cg = .false. if (present (mask_cg)) then if (mask%c) mask%cg = mask_cg else mask%cg = mask_c end if mask%hd = .false. if (present (mask_hd)) then if (.not. mask%h) mask%hd = mask_hd end if end subroutine quantum_numbers_mask_init @ %def quantum_numbers_mask_init @ Write a quantum numbers mask. We need the stand-alone subroutine for the array case. <>= public :: quantum_numbers_mask_write <>= interface quantum_numbers_mask_write module procedure quantum_numbers_mask_write_single module procedure quantum_numbers_mask_write_array end interface <>= procedure :: write => quantum_numbers_mask_write_single <>= subroutine quantum_numbers_mask_write_single (mask, unit) class(quantum_numbers_mask_t), intent(in) :: mask integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance="no") "[" write (u, "(L1)", advance="no") mask%f write (u, "(L1)", advance="no") mask%c if (.not.mask%cg) write (u, "('g')", advance="no") write (u, "(L1)", advance="no") mask%h if (mask%hd) write (u, "('d')", advance="no") write (u, "(A)", advance="no") "]" end subroutine quantum_numbers_mask_write_single subroutine quantum_numbers_mask_write_array (mask, unit) type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance="no") "[" do i = 1, size (mask) if (i > 1) write (u, "(A)", advance="no") "/" write (u, "(L1)", advance="no") mask(i)%f write (u, "(L1)", advance="no") mask(i)%c if (.not.mask(i)%cg) write (u, "('g')", advance="no") write (u, "(L1)", advance="no") mask(i)%h if (mask(i)%hd) write (u, "('d')", advance="no") end do write (u, "(A)", advance="no") "]" end subroutine quantum_numbers_mask_write_array @ %def quantum_numbers_mask_write @ \subsection{Setting mask components} <>= procedure :: set_flavor => quantum_numbers_mask_set_flavor procedure :: set_color => quantum_numbers_mask_set_color procedure :: set_helicity => quantum_numbers_mask_set_helicity procedure :: set_sub => quantum_numbers_mask_set_sub <>= elemental subroutine quantum_numbers_mask_set_flavor (mask, mask_f) class(quantum_numbers_mask_t), intent(inout) :: mask logical, intent(in) :: mask_f mask%f = mask_f end subroutine quantum_numbers_mask_set_flavor elemental subroutine quantum_numbers_mask_set_color (mask, mask_c, mask_cg) class(quantum_numbers_mask_t), intent(inout) :: mask logical, intent(in) :: mask_c logical, intent(in), optional :: mask_cg mask%c = mask_c if (present (mask_cg)) then if (mask%c) mask%cg = mask_cg else mask%cg = mask_c end if end subroutine quantum_numbers_mask_set_color elemental subroutine quantum_numbers_mask_set_helicity (mask, mask_h, mask_hd) class(quantum_numbers_mask_t), intent(inout) :: mask logical, intent(in) :: mask_h logical, intent(in), optional :: mask_hd mask%h = mask_h if (present (mask_hd)) then if (.not. mask%h) mask%hd = mask_hd end if end subroutine quantum_numbers_mask_set_helicity elemental subroutine quantum_numbers_mask_set_sub (mask, sub) class(quantum_numbers_mask_t), intent(inout) :: mask integer, intent(in) :: sub mask%sub = sub end subroutine quantum_numbers_mask_set_sub @ %def quantum_numbers_mask_set_flavor @ %def quantum_numbers_mask_set_color @ %def quantum_numbers_mask_set_helicity @ %def quantum_numbers_mask_set_sub @ The following routines assign part of a mask, depending on the flags given. <>= procedure :: assign => quantum_numbers_mask_assign <>= elemental subroutine quantum_numbers_mask_assign & (mask, mask_in, flavor, color, helicity) class(quantum_numbers_mask_t), intent(inout) :: mask class(quantum_numbers_mask_t), intent(in) :: mask_in logical, intent(in), optional :: flavor, color, helicity if (present (flavor)) then if (flavor) then mask%f = mask_in%f end if end if if (present (color)) then if (color) then mask%c = mask_in%c mask%cg = mask_in%cg end if end if if (present (helicity)) then if (helicity) then mask%h = mask_in%h mask%hd = mask_in%hd end if end if end subroutine quantum_numbers_mask_assign @ %def quantum_numbers_mask_assign @ \subsection{Mask predicates} Return true if either one of the entries is set: <>= public :: any <>= interface any module procedure quantum_numbers_mask_any end interface <>= function quantum_numbers_mask_any (mask) result (match) logical :: match type(quantum_numbers_mask_t), intent(in) :: mask match = mask%f .or. mask%c .or. mask%h .or. mask%hd end function quantum_numbers_mask_any @ %def any @ \subsection{Operators} The OR operation is applied to all components. <>= generic :: operator(.or.) => quantum_numbers_mask_or procedure, private :: quantum_numbers_mask_or @ %def .or. <>= elemental function quantum_numbers_mask_or (mask1, mask2) result (mask) type(quantum_numbers_mask_t) :: mask class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 mask%f = mask1%f .or. mask2%f mask%c = mask1%c .or. mask2%c if (mask%c) mask%cg = mask1%cg .or. mask2%cg mask%h = mask1%h .or. mask2%h if (.not. mask%h) mask%hd = mask1%hd .or. mask2%hd end function quantum_numbers_mask_or @ %def quantum_numbers_mask_or @ \subsection{Mask comparisons} Return true if the two masks are equivalent / differ: <>= generic :: operator(.eqv.) => quantum_numbers_mask_eqv generic :: operator(.neqv.) => quantum_numbers_mask_neqv procedure, private :: quantum_numbers_mask_eqv procedure, private :: quantum_numbers_mask_neqv <>= elemental function quantum_numbers_mask_eqv (mask1, mask2) result (eqv) logical :: eqv class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 eqv = (mask1%f .eqv. mask2%f) .and. & (mask1%c .eqv. mask2%c) .and. & (mask1%cg .eqv. mask2%cg) .and. & (mask1%h .eqv. mask2%h) .and. & (mask1%hd .eqv. mask2%hd) end function quantum_numbers_mask_eqv elemental function quantum_numbers_mask_neqv (mask1, mask2) result (neqv) logical :: neqv class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 neqv = (mask1%f .neqv. mask2%f) .or. & (mask1%c .neqv. mask2%c) .or. & (mask1%cg .neqv. mask2%cg) .or. & (mask1%h .neqv. mask2%h) .or. & (mask1%hd .neqv. mask2%hd) end function quantum_numbers_mask_neqv @ %def .eqv. .neqv. @ \subsection{Apply a mask} Applying a mask to the quantum number object means undefining those entries where the mask is set. The others remain unaffected. The [[hd]] mask has the special property that it ``diagonalizes'' helicity, i.e., the second helicity entry is dropped and the result is a diagonal helicity quantum number. <>= procedure :: undefine => quantum_numbers_undefine procedure :: undefined => quantum_numbers_undefined0 <>= public :: quantum_numbers_undefined <>= interface quantum_numbers_undefined module procedure quantum_numbers_undefined0 module procedure quantum_numbers_undefined1 module procedure quantum_numbers_undefined11 end interface <>= elemental subroutine quantum_numbers_undefine (qn, mask) class(quantum_numbers_t), intent(inout) :: qn type(quantum_numbers_mask_t), intent(in) :: mask if (mask%f) call qn%f%undefine () if (mask%c) call qn%c%undefine (undefine_ghost = mask%cg) if (mask%h) then call qn%h%undefine () else if (mask%hd) then if (.not. qn%h%is_diagonal ()) then call qn%h%diagonalize () end if end if if (mask%sub > 0) qn%sub = 0 end subroutine quantum_numbers_undefine function quantum_numbers_undefined0 (qn, mask) result (qn_new) class(quantum_numbers_t), intent(in) :: qn type(quantum_numbers_mask_t), intent(in) :: mask type(quantum_numbers_t) :: qn_new select type (qn) type is (quantum_numbers_t); qn_new = qn end select call quantum_numbers_undefine (qn_new, mask) end function quantum_numbers_undefined0 function quantum_numbers_undefined1 (qn, mask) result (qn_new) type(quantum_numbers_t), dimension(:), intent(in) :: qn type(quantum_numbers_mask_t), intent(in) :: mask type(quantum_numbers_t), dimension(size(qn)) :: qn_new qn_new = qn call quantum_numbers_undefine (qn_new, mask) end function quantum_numbers_undefined1 function quantum_numbers_undefined11 (qn, mask) result (qn_new) type(quantum_numbers_t), dimension(:), intent(in) :: qn type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask type(quantum_numbers_t), dimension(size(qn)) :: qn_new qn_new = qn call quantum_numbers_undefine (qn_new, mask) end function quantum_numbers_undefined11 @ %def quantum_numbers_undefine @ %def quantum_numbers_undefined @ Return true if the input quantum number set has entries that would be removed by the applied mask, e.g., if polarization is defined but [[mask%h]] is set: <>= procedure :: are_redundant => quantum_numbers_are_redundant <>= elemental function quantum_numbers_are_redundant (qn, mask) & result (redundant) logical :: redundant class(quantum_numbers_t), intent(in) :: qn type(quantum_numbers_mask_t), intent(in) :: mask redundant = .false. if (mask%f) then redundant = qn%f%is_defined () end if if (mask%c) then redundant = qn%c%is_defined () end if if (mask%h) then redundant = qn%h%is_defined () else if (mask%hd) then redundant = .not. qn%h%is_diagonal () end if if (mask%sub > 0) redundant = qn%sub >= mask%sub end function quantum_numbers_are_redundant @ %def quantum_numbers_are_redundant @ Return true if the helicity flag is set or the diagonal-helicity flag is set. <>= procedure :: diagonal_helicity => quantum_numbers_mask_diagonal_helicity <>= elemental function quantum_numbers_mask_diagonal_helicity (mask) & result (flag) logical :: flag class(quantum_numbers_mask_t), intent(in) :: mask flag = mask%h .or. mask%hd end function quantum_numbers_mask_diagonal_helicity @ %def quantum_numbers_mask_diagonal_helicity @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Transition Matrices and Evaluation} The modules in this chapter implement transition matrices and calculations. The functionality is broken down in three modules \begin{description} \item[state\_matrices] represent state and transition density matrices built from particle quantum numbers (helicity, color, flavor) \item[interactions] extend state matrices with the record of particle momenta. They also distinguish in- and out-particles and store parent-child relations. \item[evaluators] These objects extend interaction objects by the information how to calculate matrix elements from products and squares of other interactions. They implement the methods to actually compute those matrix elements. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{State matrices} This module deals with the internal state of a particle system, i.e., with its density matrix in flavor, color, and helicity space. <<[[state_matrices.f90]]>>= <> module state_matrices <> use io_units use format_utils, only: pac_fmt use format_defs, only: FMT_17, FMT_19 use diagnostics use sorting use model_data use flavors use colors use helicities use quantum_numbers <> <> <> <> <> contains <> end module state_matrices @ %def state_matrices @ \subsection{Nodes of the quantum state trie} A quantum state object represents an unnormalized density matrix, i.e., an array of possibilities for flavor, color, and helicity indices with associated complex values. Physically, the trace of this matrix is the summed squared matrix element for an interaction, and the matrix elements divided by this value correspond to the flavor-color-helicity density matrix. (Flavor and color are diagonal.) We store density matrices as tries, that is, as trees where each branching represents the possible quantum numbers of a particle. The first branching is the first particle in the system. A leaf (the node corresponding to the last particle) contains the value of the matrix element. Each node contains a flavor, color, and helicity entry. Note that each of those entries may be actually undefined, so we can also represent, e.g., unpolarized particles. The value is meaningful only for leaves, which have no child nodes. There is a pointer to the parent node which allows for following the trie downwards from a leaf, it is null for a root node. The child nodes are implemented as a list, so there is a pointer to the first and last child, and each node also has a [[next]] pointer to the next sibling. The root node does not correspond to a particle, only its children do. The quantum numbers of the root node are irrelevant and will not be set. However, we use a common type for the three classes (root, branch, leaf); they may easily be distinguished by the association status of parent and child. \subsubsection{Node type} The node is linked in all directions: the parent, the first and last in the list of children, and the previous and next sibling. This allows us for adding and removing nodes and whole branches anywhere in the trie. (Circular links are not allowed, however.). The node holds its associated set of quantum numbers. The integer index, which is set only for leaf nodes, is the index of the corresponding matrix element value within the state matrix. Temporarily, matrix-element values may be stored within a leaf node. This is used during state-matrix factorization. When the state matrix is [[freeze]]d, these values are transferred to the matrix-element array within the host state matrix. <>= type :: node_t private type(quantum_numbers_t) :: qn type(node_t), pointer :: parent => null () type(node_t), pointer :: child_first => null () type(node_t), pointer :: child_last => null () type(node_t), pointer :: next => null () type(node_t), pointer :: previous => null () integer :: me_index = 0 integer, dimension(:), allocatable :: me_count complex(default) :: me = 0 end type node_t @ %def node_t @ \subsubsection{Operations on nodes} Recursively deallocate all children of the current node. This includes any values associated with the children. <>= pure recursive subroutine node_delete_offspring (node) type(node_t), pointer :: node type(node_t), pointer :: child child => node%child_first do while (associated (child)) node%child_first => node%child_first%next call node_delete_offspring (child) deallocate (child) child => node%child_first end do node%child_last => null () end subroutine node_delete_offspring @ %def node_delete_offspring @ Remove a node including its offspring. Adjust the pointers of parent and siblings, if necessary. <>= pure subroutine node_delete (node) type(node_t), pointer :: node call node_delete_offspring (node) if (associated (node%previous)) then node%previous%next => node%next else if (associated (node%parent)) then node%parent%child_first => node%next end if if (associated (node%next)) then node%next%previous => node%previous else if (associated (node%parent)) then node%parent%child_last => node%previous end if deallocate (node) end subroutine node_delete @ %def node_delete @ Append a child node <>= subroutine node_append_child (node, child) type(node_t), target, intent(inout) :: node type(node_t), pointer :: child allocate (child) if (associated (node%child_last)) then node%child_last%next => child child%previous => node%child_last else node%child_first => child end if node%child_last => child child%parent => node end subroutine node_append_child @ %def node_append_child @ \subsubsection{I/O} Output of a single node, no recursion. We print the quantum numbers in square brackets, then the value (if any). <>= subroutine node_write (node, me_array, verbose, unit, col_verbose, testflag) type(node_t), intent(in) :: node complex(default), dimension(:), intent(in), optional :: me_array logical, intent(in), optional :: verbose, col_verbose, testflag integer, intent(in), optional :: unit logical :: verb integer :: u character(len=7) :: fmt call pac_fmt (fmt, FMT_19, FMT_17, testflag) verb = .false.; if (present (verbose)) verb = verbose u = given_output_unit (unit); if (u < 0) return call node%qn%write (u, col_verbose) if (node%me_index /= 0) then write (u, "(A,I0,A)", advance="no") " => ME(", node%me_index, ")" if (present (me_array)) then write (u, "(A)", advance="no") " = " write (u, "('('," // fmt // ",','," // fmt // ",')')", & advance="no") pacify_complex (me_array(node%me_index)) end if end if write (u, *) if (verb) then call ptr_write ("parent ", node%parent) call ptr_write ("child_first", node%child_first) call ptr_write ("child_last ", node%child_last) call ptr_write ("next ", node%next) call ptr_write ("previous ", node%previous) end if contains subroutine ptr_write (label, node) character(*), intent(in) :: label type(node_t), pointer :: node if (associated (node)) then write (u, "(10x,A,1x,'->',1x)", advance="no") label call node%qn%write (u, col_verbose) write (u, *) end if end subroutine ptr_write end subroutine node_write @ %def node_write @ Recursive output of a node: <>= recursive subroutine node_write_rec (node, me_array, verbose, & indent, unit, col_verbose, testflag) type(node_t), intent(in), target :: node complex(default), dimension(:), intent(in), optional :: me_array logical, intent(in), optional :: verbose, col_verbose, testflag integer, intent(in), optional :: indent integer, intent(in), optional :: unit type(node_t), pointer :: current logical :: verb integer :: i, u verb = .false.; if (present (verbose)) verb = verbose i = 0; if (present (indent)) i = indent u = given_output_unit (unit); if (u < 0) return current => node%child_first do while (associated (current)) write (u, "(A)", advance="no") repeat (" ", i) call node_write (current, me_array, verbose = verb, & unit = u, col_verbose = col_verbose, testflag = testflag) call node_write_rec (current, me_array, verbose = verb, & indent = i + 2, unit = u, col_verbose = col_verbose, testflag = testflag) current => current%next end do end subroutine node_write_rec @ %def node_write_rec @ Binary I/O. Matrix elements are written only for leaf nodes. <>= recursive subroutine node_write_raw_rec (node, u) type(node_t), intent(in), target :: node integer, intent(in) :: u logical :: associated_child_first, associated_next call node%qn%write_raw (u) associated_child_first = associated (node%child_first) write (u) associated_child_first associated_next = associated (node%next) write (u) associated_next if (associated_child_first) then call node_write_raw_rec (node%child_first, u) else write (u) node%me_index write (u) node%me end if if (associated_next) then call node_write_raw_rec (node%next, u) end if end subroutine node_write_raw_rec recursive subroutine node_read_raw_rec (node, u, parent, iostat) type(node_t), intent(out), target :: node integer, intent(in) :: u type(node_t), intent(in), optional, target :: parent integer, intent(out), optional :: iostat logical :: associated_child_first, associated_next type(node_t), pointer :: child call node%qn%read_raw (u, iostat=iostat) read (u, iostat=iostat) associated_child_first read (u, iostat=iostat) associated_next if (present (parent)) node%parent => parent if (associated_child_first) then allocate (child) node%child_first => child node%child_last => null () call node_read_raw_rec (child, u, node, iostat=iostat) do while (associated (child)) child%previous => node%child_last node%child_last => child child => child%next end do else read (u, iostat=iostat) node%me_index read (u, iostat=iostat) node%me end if if (associated_next) then allocate (node%next) call node_read_raw_rec (node%next, u, parent, iostat=iostat) end if end subroutine node_read_raw_rec @ %def node_write_raw @ \subsection{State matrix} \subsubsection{Definition} The quantum state object is a container that keeps and hides the root node. For direct accessibility of values, they are stored in a separate array. The leaf nodes of the quantum-number tree point to those values, once the state matrix is finalized. The [[norm]] component is redefined if a common factor is extracted from all nodes. <>= public :: state_matrix_t <>= type :: state_matrix_t private type(node_t), pointer :: root => null () integer :: depth = 0 integer :: n_matrix_elements = 0 logical :: leaf_nodes_store_values = .false. integer :: n_counters = 0 complex(default), dimension(:), allocatable :: me real(default) :: norm = 1 integer :: n_sub = -1 contains <> end type state_matrix_t @ %def state_matrix_t @ This initializer allocates the root node but does not fill anything. We declare whether values are stored within the nodes during state-matrix construction, and how many counters should be maintained (default: none). <>= procedure :: init => state_matrix_init <>= subroutine state_matrix_init (state, store_values, n_counters) class(state_matrix_t), intent(out) :: state logical, intent(in), optional :: store_values integer, intent(in), optional :: n_counters allocate (state%root) if (present (store_values)) & state%leaf_nodes_store_values = store_values if (present (n_counters)) state%n_counters = n_counters end subroutine state_matrix_init @ %def state_matrix_init @ This recursively deletes all children of the root node, restoring the initial state. The matrix element array is not finalized, since it does not contain physical entries, just pointers. <>= procedure :: final => state_matrix_final <>= subroutine state_matrix_final (state) class(state_matrix_t), intent(inout) :: state if (allocated (state%me)) deallocate (state%me) if (associated (state%root)) call node_delete (state%root) state%depth = 0 state%n_matrix_elements = 0 end subroutine state_matrix_final @ %def state_matrix_final @ Output: Present the tree as a nested list with appropriate indentation. <>= procedure :: write => state_matrix_write <>= subroutine state_matrix_write (state, unit, write_value_list, & verbose, col_verbose, testflag) class(state_matrix_t), intent(in) :: state logical, intent(in), optional :: write_value_list, verbose, col_verbose logical, intent(in), optional :: testflag integer, intent(in), optional :: unit complex(default) :: me_dum character(len=7) :: fmt integer :: u integer :: i call pac_fmt (fmt, FMT_19, FMT_17, testflag) u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A," // fmt // ")") "State matrix: norm = ", state%norm if (associated (state%root)) then if (allocated (state%me)) then call node_write_rec (state%root, state%me, verbose = verbose, & indent = 1, unit = u, col_verbose = col_verbose, & testflag = testflag) else call node_write_rec (state%root, verbose = verbose, indent = 1, & unit = u, col_verbose = col_verbose, testflag = testflag) end if end if if (present (write_value_list)) then if (write_value_list .and. allocated (state%me)) then do i = 1, size (state%me) write (u, "(1x,I0,A)", advance="no") i, ":" me_dum = state%me(i) if (real(state%me(i)) == -real(state%me(i))) then me_dum = & cmplx (0._default, aimag(me_dum), kind=default) end if if (aimag(me_dum) == -aimag(me_dum)) then me_dum = & cmplx (real(me_dum), 0._default, kind=default) end if write (u, "('('," // fmt // ",','," // fmt // & ",')')") me_dum end do end if end if end subroutine state_matrix_write @ %def state_matrix_write @ Binary I/O. The auxiliary matrix-element array is not written, but reconstructed after reading the tree. Note: To be checked. Might be broken, don't use (unless trivial). <>= procedure :: write_raw => state_matrix_write_raw procedure :: read_raw => state_matrix_read_raw <>= subroutine state_matrix_write_raw (state, u) class(state_matrix_t), intent(in), target :: state integer, intent(in) :: u logical :: is_defined integer :: depth, j type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn is_defined = state%is_defined () write (u) is_defined if (is_defined) then write (u) state%get_norm () write (u) state%get_n_leaves () depth = state%get_depth () write (u) depth allocate (qn (depth)) call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () do j = 1, depth call qn(j)%write_raw (u) end do write (u) it%get_me_index () write (u) it%get_matrix_element () call it%advance () end do end if end subroutine state_matrix_write_raw subroutine state_matrix_read_raw (state, u, iostat) class(state_matrix_t), intent(out) :: state integer, intent(in) :: u integer, intent(out) :: iostat logical :: is_defined real(default) :: norm integer :: n_leaves, depth, i, j type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: me_index complex(default) :: me read (u, iostat=iostat) is_defined if (iostat /= 0) goto 1 if (is_defined) then call state%init (store_values = .true.) read (u, iostat=iostat) norm if (iostat /= 0) goto 1 call state_matrix_set_norm (state, norm) read (u) n_leaves if (iostat /= 0) goto 1 read (u) depth if (iostat /= 0) goto 1 allocate (qn (depth)) do i = 1, n_leaves do j = 1, depth call qn(j)%read_raw (u, iostat=iostat) if (iostat /= 0) goto 1 end do read (u, iostat=iostat) me_index if (iostat /= 0) goto 1 read (u, iostat=iostat) me if (iostat /= 0) goto 1 call state%add_state (qn, index = me_index, value = me) end do call state_matrix_freeze (state) end if return ! Clean up on error 1 continue call state%final () end subroutine state_matrix_read_raw @ %def state_matrix_write_raw state_matrix_read_raw @ Assign a model pointer to all flavor entries. This will become necessary when we have read a state matrix from file. <>= procedure :: set_model => state_matrix_set_model <>= subroutine state_matrix_set_model (state, model) class(state_matrix_t), intent(inout), target :: state class(model_data_t), intent(in), target :: model type(state_iterator_t) :: it call it%init (state) do while (it%is_valid ()) call it%set_model (model) call it%advance () end do end subroutine state_matrix_set_model @ %def state_matrix_set_model @ Iterate over [[state]], get the quantum numbers array [[qn]] for each iteration, and tag all array elements of [[qn]] with the indizes given by [[tag]] as part of the hard interaction. Then add them to [[tagged_state]] and return it. If no [[tag]] is given, tag all [[qn]] as part of the hard process. <>= procedure :: tag_hard_process => state_matrix_tag_hard_process <>= subroutine state_matrix_tag_hard_process (state, tagged_state, tag) class(state_matrix_t), intent(in), target :: state type(state_matrix_t), intent(out) :: tagged_state integer, dimension(:), intent(in), optional :: tag type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn complex(default) :: value integer :: i call tagged_state%init (store_values = .true.) call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () value = it%get_matrix_element () if (present (tag)) then do i = 1, size (tag) call qn(tag(i))%tag_hard_process () end do else call qn%tag_hard_process () end if call tagged_state%add_state (qn, index = it%get_me_index (), value = value) call it%advance () end do call tagged_state%freeze () end subroutine state_matrix_tag_hard_process @ %def state_matrix_tag_hard_process \subsubsection{Properties of the quantum state} A state is defined if its root is allocated: <>= procedure :: is_defined => state_matrix_is_defined <>= elemental function state_matrix_is_defined (state) result (defined) logical :: defined class(state_matrix_t), intent(in) :: state defined = associated (state%root) end function state_matrix_is_defined @ %def state_matrix_is_defined @ A state is empty if its depth is zero: <>= procedure :: is_empty => state_matrix_is_empty <>= elemental function state_matrix_is_empty (state) result (flag) logical :: flag class(state_matrix_t), intent(in) :: state flag = state%depth == 0 end function state_matrix_is_empty @ %def state_matrix_is_empty @ Return the number of matrix-element values. <>= generic :: get_n_matrix_elements => get_n_matrix_elements_all, get_n_matrix_elements_mask procedure :: get_n_matrix_elements_all => state_matrix_get_n_matrix_elements_all procedure :: get_n_matrix_elements_mask => state_matrix_get_n_matrix_elements_mask <>= pure function state_matrix_get_n_matrix_elements_all (state) result (n) integer :: n class(state_matrix_t), intent(in) :: state n = state%n_matrix_elements end function state_matrix_get_n_matrix_elements_all @ %def state_matrix_get_n_matrix_elements_all @ <>= function state_matrix_get_n_matrix_elements_mask (state, qn_mask) result (n) integer :: n class(state_matrix_t), intent(in) :: state type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask type(state_iterator_t) :: it type(quantum_numbers_t), dimension(size(qn_mask)) :: qn type(state_matrix_t) :: state_tmp call state_tmp%init () call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () call qn%undefine (qn_mask) call state_tmp%add_state (qn) call it%advance () end do n = state_tmp%n_matrix_elements call state_tmp%final () end function state_matrix_get_n_matrix_elements_mask @ %def state_matrix_get_n_matrix_elments_mask @ Return the size of the [[me]]-array for debugging purposes. <>= procedure :: get_me_size => state_matrix_get_me_size <>= pure function state_matrix_get_me_size (state) result (n) integer :: n class(state_matrix_t), intent(in) :: state if (allocated (state%me)) then n = size (state%me) else n = 0 end if end function state_matrix_get_me_size @ %def state_matrix_get_me_size @ <>= procedure :: compute_n_sub => state_matrix_compute_n_sub <>= function state_matrix_compute_n_sub (state) result (n_sub) integer :: n_sub class(state_matrix_t), intent(in) :: state type(state_iterator_t) :: it type(quantum_numbers_t), dimension(state%depth) :: qn integer :: sub, sub_pos n_sub = 0 call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () sub = 0 sub_pos = qn_array_sub_pos () if (sub_pos > 0) sub = qn(sub_pos)%get_sub () if (sub > n_sub) n_sub = sub call it%advance () end do contains function qn_array_sub_pos () result (pos) integer :: pos integer :: i pos = 0 do i = 1, state%depth if (qn(i)%get_sub () > 0) then pos = i exit end if end do end function qn_array_sub_pos end function state_matrix_compute_n_sub @ %def state_matrix_compute_n_sub @ <>= procedure :: set_n_sub => state_matrix_set_n_sub <>= subroutine state_matrix_set_n_sub (state) class(state_matrix_t), intent(inout) :: state state%n_sub = state%compute_n_sub () end subroutine state_matrix_set_n_sub @ %def state_matrix_set_n_sub @ Return number of subtractions. <>= procedure :: get_n_sub => state_matrix_get_n_sub <>= function state_matrix_get_n_sub (state) result (n_sub) integer :: n_sub class(state_matrix_t), intent(in) :: state if (state%n_sub < 0) then call msg_bug ("[state_matrix_get_n_sub] number of subtractions not set.") end if n_sub = state%n_sub end function state_matrix_get_n_sub @ %def state_matrix_get_n_sub @ Return the number of leaves. This can be larger than the number of independent matrix elements. <>= procedure :: get_n_leaves => state_matrix_get_n_leaves <>= function state_matrix_get_n_leaves (state) result (n) integer :: n class(state_matrix_t), intent(in) :: state type(state_iterator_t) :: it n = 0 call it%init (state) do while (it%is_valid ()) n = n + 1 call it%advance () end do end function state_matrix_get_n_leaves @ %def state_matrix_get_n_leaves @ Return the depth: <>= procedure :: get_depth => state_matrix_get_depth <>= pure function state_matrix_get_depth (state) result (depth) integer :: depth class(state_matrix_t), intent(in) :: state depth = state%depth end function state_matrix_get_depth @ %def state_matrix_get_depth @ Return the norm: <>= procedure :: get_norm => state_matrix_get_norm <>= pure function state_matrix_get_norm (state) result (norm) real(default) :: norm class(state_matrix_t), intent(in) :: state norm = state%norm end function state_matrix_get_norm @ %def state_matrix_get_norm @ \subsubsection{Retrieving contents} Return the quantum number array, using an index. We have to scan the state matrix since there is no shortcut. <>= procedure :: get_quantum_number => & state_matrix_get_quantum_number <>= function state_matrix_get_quantum_number (state, i, by_me_index) result (qn) class(state_matrix_t), intent(in), target :: state integer, intent(in) :: i logical, intent(in), optional :: by_me_index logical :: opt_by_me_index type(quantum_numbers_t), dimension(state%depth) :: qn type(state_iterator_t) :: it integer :: k opt_by_me_index = .false. if (present (by_me_index)) opt_by_me_index = by_me_index k = 0 call it%init (state) do while (it%is_valid ()) if (opt_by_me_index) then k = it%get_me_index () else k = k + 1 end if if (k == i) then qn = it%get_quantum_numbers () exit end if call it%advance () end do end function state_matrix_get_quantum_number @ %def state_matrix_get_quantum_number <>= generic :: get_quantum_numbers => get_quantum_numbers_all, get_quantum_numbers_mask procedure :: get_quantum_numbers_all => state_matrix_get_quantum_numbers_all procedure :: get_quantum_numbers_mask => state_matrix_get_quantum_numbers_mask <>= subroutine state_matrix_get_quantum_numbers_all (state, qn) class(state_matrix_t), intent(in), target :: state type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn integer :: i allocate (qn (state%get_n_matrix_elements (), & state%get_depth())) do i = 1, state%get_n_matrix_elements () qn (i, :) = state%get_quantum_number (i) end do end subroutine state_matrix_get_quantum_numbers_all @ %def state_matrix_get_quantum_numbers_all @ <>= subroutine state_matrix_get_quantum_numbers_mask (state, qn_mask, qn) class(state_matrix_t), intent(in), target :: state type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn type(quantum_numbers_t), dimension(:), allocatable :: qn_tmp type(state_matrix_t) :: state_tmp type(state_iterator_t) :: it integer :: i, n n = state%get_n_matrix_elements (qn_mask) allocate (qn (n, state%get_depth ())) allocate (qn_tmp (state%get_depth ())) call it%init (state) call state_tmp%init () do while (it%is_valid ()) qn_tmp = it%get_quantum_numbers () call qn_tmp%undefine (qn_mask) call state_tmp%add_state (qn_tmp) call it%advance () end do do i = 1, n qn (i, :) = state_tmp%get_quantum_number (i) end do call state_tmp%final () end subroutine state_matrix_get_quantum_numbers_mask @ %def state_matrix_get_quantum_numbers_mask @ <>= procedure :: get_flavors => state_matrix_get_flavors <>= subroutine state_matrix_get_flavors (state, only_elementary, qn_mask, flv) class(state_matrix_t), intent(in), target :: state logical, intent(in) :: only_elementary type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask integer, intent(out), dimension(:,:), allocatable :: flv type(quantum_numbers_t), dimension(:,:), allocatable :: qn integer :: i_flv, n_partons type(flavor_t), dimension(:), allocatable :: flv_flv if (present (qn_mask)) then call state%get_quantum_numbers (qn_mask, qn) else call state%get_quantum_numbers (qn) end if allocate (flv_flv (size (qn, dim=2))) if (only_elementary) then flv_flv = qn(1, :)%get_flavor () n_partons = count (is_elementary (flv_flv%get_pdg ())) end if allocate (flv (n_partons, size (qn, dim=1))) associate (n_flv => size (qn, dim=1)) do i_flv = 1, size (qn, dim=1) flv_flv = qn(i_flv, :)%get_flavor () flv(:, i_flv) = pack (flv_flv%get_pdg (), is_elementary(flv_flv%get_pdg())) end do end associate contains elemental function is_elementary (pdg) logical :: is_elementary integer, intent(in) :: pdg is_elementary = abs(pdg) /= 2212 .and. abs(pdg) /= 92 .and. abs(pdg) /= 93 end function is_elementary end subroutine state_matrix_get_flavors @ %def state_matrix_get_flavors @ Return a single matrix element using its index. Works only if the shortcut array is allocated. <>= generic :: get_matrix_element => get_matrix_element_single generic :: get_matrix_element => get_matrix_element_array procedure :: get_matrix_element_single => & state_matrix_get_matrix_element_single procedure :: get_matrix_element_array => & state_matrix_get_matrix_element_array <>= elemental function state_matrix_get_matrix_element_single (state, i) result (me) complex(default) :: me class(state_matrix_t), intent(in) :: state integer, intent(in) :: i if (allocated (state%me)) then me = state%me(i) else me = 0 end if end function state_matrix_get_matrix_element_single @ %def state_matrix_get_matrix_element_single @ <>= function state_matrix_get_matrix_element_array (state) result (me) complex(default), dimension(:), allocatable :: me class(state_matrix_t), intent(in) :: state if (allocated (state%me)) then allocate (me (size (state%me))) me = state%me else me = 0 end if end function state_matrix_get_matrix_element_array @ %def state_matrix_get_matrix_element_array @ Return the color index with maximum absolute value that is present within the state matrix. <>= procedure :: get_max_color_value => state_matrix_get_max_color_value <>= function state_matrix_get_max_color_value (state) result (cmax) integer :: cmax class(state_matrix_t), intent(in) :: state if (associated (state%root)) then cmax = node_get_max_color_value (state%root) else cmax = 0 end if contains recursive function node_get_max_color_value (node) result (cmax) integer :: cmax type(node_t), intent(in), target :: node type(node_t), pointer :: current cmax = quantum_numbers_get_max_color_value (node%qn) current => node%child_first do while (associated (current)) cmax = max (cmax, node_get_max_color_value (current)) current => current%next end do end function node_get_max_color_value end function state_matrix_get_max_color_value @ %def state_matrix_get_max_color_value @ \subsubsection{Building the quantum state} The procedure generates a branch associated to the input array of quantum numbers. If the branch exists already, it is used. Optionally, we set the matrix-element index, a value (which may be added to the previous one), and increment one of the possible counters. We may also return the matrix element index of the current node. <>= procedure :: add_state => state_matrix_add_state <>= subroutine state_matrix_add_state (state, qn, index, value, & sum_values, counter_index, ignore_sub_for_qn, me_index) class(state_matrix_t), intent(inout) :: state type(quantum_numbers_t), dimension(:), intent(in) :: qn integer, intent(in), optional :: index complex(default), intent(in), optional :: value logical, intent(in), optional :: sum_values integer, intent(in), optional :: counter_index logical, intent(in), optional :: ignore_sub_for_qn integer, intent(out), optional :: me_index logical :: set_index, get_index, add set_index = present (index) get_index = present (me_index) add = .false.; if (present (sum_values)) add = sum_values if (state%depth == 0) then state%depth = size (qn) else if (state%depth /= size (qn)) then call state%write () call msg_bug ("State matrix: depth mismatch") end if if (size (qn) > 0) call node_make_branch (state%root, qn) contains recursive subroutine node_make_branch (parent, qn) type(node_t), pointer :: parent type(quantum_numbers_t), dimension(:), intent(in) :: qn type(node_t), pointer :: child logical :: match match = .false. child => parent%child_first SCAN_CHILDREN: do while (associated (child)) if (present (ignore_sub_for_qn)) then if (ignore_sub_for_qn) then match = quantum_numbers_eq_wo_sub (child%qn, qn(1)) else match = child%qn == qn(1) end if else match = child%qn == qn(1) end if if (match) exit SCAN_CHILDREN child => child%next end do SCAN_CHILDREN if (.not. match) then call node_append_child (parent, child) child%qn = qn(1) end if select case (size (qn)) case (1) if (.not. match) then state%n_matrix_elements = state%n_matrix_elements + 1 child%me_index = state%n_matrix_elements end if if (set_index) then child%me_index = index end if if (get_index) then me_index = child%me_index end if if (present (counter_index)) then if (.not. allocated (child%me_count)) then allocate (child%me_count (state%n_counters)) child%me_count = 0 end if child%me_count(counter_index) = child%me_count(counter_index) + 1 end if if (present (value)) then if (add) then child%me = child%me + value else child%me = value end if end if case (2:) call node_make_branch (child, qn(2:)) end select end subroutine node_make_branch end subroutine state_matrix_add_state @ %def state_matrix_add_state @ Remove irrelevant flavor/color/helicity labels and the corresponding branchings. The masks indicate which particles are affected; the masks length should coincide with the depth of the trie (without the root node). Recursively scan the whole tree, starting from the leaf nodes and working up to the root node. If a mask entry is set for the current tree level, scan the children there. For each child within that level make a new empty branch where the masked quantum number is undefined. Then recursively combine all following children with matching quantum number into this new node and move on. <>= procedure :: collapse => state_matrix_collapse <>= subroutine state_matrix_collapse (state, mask) class(state_matrix_t), intent(inout) :: state type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask type(state_matrix_t) :: red_state if (state%is_defined ()) then call state%reduce (mask, red_state) call state%final () state = red_state end if end subroutine state_matrix_collapse @ %def state_matrix_collapse @ Transform the given state matrix into a reduced state matrix where some quantum numbers are removed, as indicated by the mask. The procedure creates a new state matrix, so the old one can be deleted after this if it is no longer used. It is said that the matrix element ordering is lost afterwards. We allow to keep the original matrix element index in the new state matrix. If the matrix element indices are kept, we do not freeze the state matrix. After reordering the matrix element indices by [[state_matrix_reorder_me]], the state matrix can be frozen. <>= procedure :: reduce => state_matrix_reduce <>= subroutine state_matrix_reduce (state, mask, red_state, keep_me_index) class(state_matrix_t), intent(in), target :: state type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask type(state_matrix_t), intent(out) :: red_state logical, optional, intent(in) :: keep_me_index logical :: opt_keep_me_index type(state_iterator_t) :: it type(quantum_numbers_t), dimension(size(mask)) :: qn opt_keep_me_index = .false. if (present (keep_me_index)) opt_keep_me_index = keep_me_index call red_state%init () call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () call qn%undefine (mask) if (opt_keep_me_index) then call red_state%add_state (qn, index = it%get_me_index ()) else call red_state%add_state (qn) end if call it%advance () end do if (.not. opt_keep_me_index) then call red_state%freeze () end if end subroutine state_matrix_reduce @ %def state_matrix_reduce @ Reorder the matrix elements -- not the tree itself. The procedure is necessary in case the matrix element indices were kept when reducing over quantum numbers and one wants to reintroduce the previous order of the matrix elements. <>= procedure :: reorder_me => state_matrix_reorder_me <>= subroutine state_matrix_reorder_me (state, ordered_state) class(state_matrix_t), intent(in), target :: state type(state_matrix_t), intent(out) :: ordered_state type(state_iterator_t) :: it type(quantum_numbers_t), dimension(state%depth) :: qn integer, dimension(:), allocatable :: me_index integer :: i call ordered_state%init () call get_me_index_sorted (state, me_index) i = 1; call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () call ordered_state%add_state (qn, index = me_index(i)) i = i + 1; call it%advance () end do call ordered_state%freeze () contains subroutine get_me_index_sorted (state, me_index) class(state_matrix_t), intent(in), target :: state integer, dimension(:), allocatable, intent(out) :: me_index type(state_iterator_t) :: it integer :: i, j integer, dimension(:), allocatable :: me_index_unsorted, me_index_sorted associate (n_matrix_elements => state%get_n_matrix_elements ()) allocate (me_index(n_matrix_elements), source = 0) allocate (me_index_sorted(n_matrix_elements), source = 0) allocate (me_index_unsorted(n_matrix_elements), source = 0) i = 1; call it%init (state) do while (it%is_valid ()) me_index_unsorted(i) = it%get_me_index () i = i + 1 call it%advance () end do me_index_sorted = sort (me_index_unsorted) ! We do not care about efficiency at this point. UNSORTED: do i = 1, n_matrix_elements SORTED: do j = 1, n_matrix_elements if (me_index_unsorted(i) == me_index_sorted(j)) then me_index(i) = j cycle UNSORTED end if end do SORTED end do UNSORTED end associate end subroutine get_me_index_sorted end subroutine state_matrix_reorder_me @ %def state_matrix_order_by_flavors @ This subroutine sets up the matrix-element array. The leaf nodes aquire the index values that point to the appropriate matrix-element entry. We recursively scan the trie. Once we arrive at a leaf node, the index is increased and associated to that node. Finally, we allocate the matrix-element array with the appropriate size. If matrix element values are temporarily stored within the leaf nodes, we scan the state again and transfer them to the matrix-element array. <>= procedure :: freeze => state_matrix_freeze <>= subroutine state_matrix_freeze (state) class(state_matrix_t), intent(inout), target :: state type(state_iterator_t) :: it if (associated (state%root)) then if (allocated (state%me)) deallocate (state%me) allocate (state%me (state%n_matrix_elements)) state%me = 0 call state%set_n_sub () end if if (state%leaf_nodes_store_values) then call it%init (state) do while (it%is_valid ()) state%me(it%get_me_index ()) = it%get_matrix_element () call it%advance () end do state%leaf_nodes_store_values = .false. end if end subroutine state_matrix_freeze @ %def state_matrix_freeze @ \subsubsection{Direct access to the value array} Several methods for setting a value directly are summarized in this generic: <>= generic :: set_matrix_element => set_matrix_element_qn generic :: set_matrix_element => set_matrix_element_all generic :: set_matrix_element => set_matrix_element_array generic :: set_matrix_element => set_matrix_element_single generic :: set_matrix_element => set_matrix_element_clone procedure :: set_matrix_element_qn => state_matrix_set_matrix_element_qn procedure :: set_matrix_element_all => state_matrix_set_matrix_element_all procedure :: set_matrix_element_array => & state_matrix_set_matrix_element_array procedure :: set_matrix_element_single => & state_matrix_set_matrix_element_single procedure :: set_matrix_element_clone => & state_matrix_set_matrix_element_clone @ %def state_matrix_set_matrix_element @ Set a value that corresponds to a quantum number array: <>= subroutine state_matrix_set_matrix_element_qn (state, qn, value) class(state_matrix_t), intent(inout), target :: state type(quantum_numbers_t), dimension(:), intent(in) :: qn complex(default), intent(in) :: value type(state_iterator_t) :: it if (.not. allocated (state%me)) then allocate (state%me (size(qn))) end if call it%init (state) call it%go_to_qn (qn) call it%set_matrix_element (value) end subroutine state_matrix_set_matrix_element_qn @ %def state_matrix_set_matrix_element_qn @ Set all matrix elements to a single value <>= subroutine state_matrix_set_matrix_element_all (state, value) class(state_matrix_t), intent(inout) :: state complex(default), intent(in) :: value if (.not. allocated (state%me)) then allocate (state%me (state%n_matrix_elements)) end if state%me = value end subroutine state_matrix_set_matrix_element_all @ %def state_matrix_set_matrix_element_all @ Set the matrix-element array directly. <>= subroutine state_matrix_set_matrix_element_array (state, value, range) class(state_matrix_t), intent(inout) :: state complex(default), intent(in), dimension(:) :: value integer, intent(in), dimension(:), optional :: range if (present (range)) then state%me(range) = value else if (.not. allocated (state%me)) & allocate (state%me (size (value))) state%me(:) = value end if end subroutine state_matrix_set_matrix_element_array @ %def state_matrix_set_matrix_element_array @ Set a matrix element at position [[i]] to [[value]]. <>= pure subroutine state_matrix_set_matrix_element_single (state, i, value) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i complex(default), intent(in) :: value if (.not. allocated (state%me)) then allocate (state%me (state%n_matrix_elements)) end if state%me(i) = value end subroutine state_matrix_set_matrix_element_single @ %def state_matrix_set_matrix_element_single @ Clone the matrix elements from another (matching) state matrix. <>= subroutine state_matrix_set_matrix_element_clone (state, state1) class(state_matrix_t), intent(inout) :: state type(state_matrix_t), intent(in) :: state1 if (.not. allocated (state1%me)) return if (.not. allocated (state%me)) allocate (state%me (size (state1%me))) state%me = state1%me end subroutine state_matrix_set_matrix_element_clone @ %def state_matrix_set_matrix_element_clone @ Add a value to a matrix element <>= procedure :: add_to_matrix_element => state_matrix_add_to_matrix_element <>= subroutine state_matrix_add_to_matrix_element (state, qn, value, match_only_flavor) class(state_matrix_t), intent(inout), target :: state type(quantum_numbers_t), dimension(:), intent(in) :: qn complex(default), intent(in) :: value logical, intent(in), optional :: match_only_flavor type(state_iterator_t) :: it call it%init (state) call it%go_to_qn (qn, match_only_flavor) if (it%is_valid ()) then call it%add_to_matrix_element (value) else call msg_fatal ("Cannot add to matrix element - it%node not allocated") end if end subroutine state_matrix_add_to_matrix_element @ %def state_matrix_add_to_matrix_element @ \subsection{State iterators} Accessing the quantum state from outside is best done using a specialized iterator, i.e., a pointer to a particular branch of the quantum state trie. Technically, the iterator contains a pointer to a leaf node, but via parent pointers it allows to access the whole branch where the leaf is attached. For quick access, we also keep the branch depth (which is assumed to be universal for a quantum state). <>= public :: state_iterator_t <>= type :: state_iterator_t private integer :: depth = 0 type(state_matrix_t), pointer :: state => null () type(node_t), pointer :: node => null () contains <> end type state_iterator_t @ %def state_iterator @ The initializer: Point at the first branch. Note that this cannot be pure, thus not be elemental, because the iterator can be used to manipulate data in the state matrix. <>= procedure :: init => state_iterator_init <>= subroutine state_iterator_init (it, state) class(state_iterator_t), intent(out) :: it type(state_matrix_t), intent(in), target :: state it%state => state it%depth = state%depth if (state%is_defined ()) then it%node => state%root do while (associated (it%node%child_first)) it%node => it%node%child_first end do else it%node => null () end if end subroutine state_iterator_init @ %def state_iterator_init @ Go forward. Recursively programmed: if the next node does not exist, go back to the parent node and look at its successor (if present), etc. There is a possible pitfall in the implementation: If the dummy pointer argument to the [[find_next]] routine is used directly, we still get the correct result for the iterator, but calling the recursion on [[node%parent]] means that we manipulate a parent pointer in the original state in addition to the iterator. Making a local copy of the pointer avoids this. Using pointer intent would be helpful, but we do not yet rely on this F2003 feature. <>= procedure :: advance => state_iterator_advance <>= subroutine state_iterator_advance (it) class(state_iterator_t), intent(inout) :: it call find_next (it%node) contains recursive subroutine find_next (node_in) type(node_t), intent(in), target :: node_in type(node_t), pointer :: node node => node_in if (associated (node%next)) then node => node%next do while (associated (node%child_first)) node => node%child_first end do it%node => node else if (associated (node%parent)) then call find_next (node%parent) else it%node => null () end if end subroutine find_next end subroutine state_iterator_advance @ %def state_iterator_advance @ If all has been scanned, the iterator is at an undefined state. Check for this: <>= procedure :: is_valid => state_iterator_is_valid <>= function state_iterator_is_valid (it) result (defined) logical :: defined class(state_iterator_t), intent(in) :: it defined = associated (it%node) end function state_iterator_is_valid @ %def state_iterator_is_valid @ Return the matrix-element index that corresponds to the current node <>= procedure :: get_me_index => state_iterator_get_me_index <>= function state_iterator_get_me_index (it) result (n) integer :: n class(state_iterator_t), intent(in) :: it n = it%node%me_index end function state_iterator_get_me_index @ %def state_iterator_get_me_index @ Return the number of times this quantum-number state has been added (noting that it is physically inserted only the first time). Note that for each state, there is an array of counters. <>= procedure :: get_me_count => state_iterator_get_me_count <>= function state_iterator_get_me_count (it) result (n) integer, dimension(:), allocatable :: n class(state_iterator_t), intent(in) :: it if (allocated (it%node%me_count)) then allocate (n (size (it%node%me_count))) n = it%node%me_count else allocate (n (0)) end if end function state_iterator_get_me_count @ %def state_iterator_get_me_count @ <>= procedure :: get_depth => state_iterator_get_depth <>= pure function state_iterator_get_depth (state_iterator) result (depth) integer :: depth class(state_iterator_t), intent(in) :: state_iterator depth = state_iterator%depth end function state_iterator_get_depth @ %def state_iterator_get_depth @ Proceed to the state associated with the quantum numbers [[qn]]. <>= procedure :: go_to_qn => state_iterator_go_to_qn <>= subroutine state_iterator_go_to_qn (it, qn, match_only_flavor) class(state_iterator_t), intent(inout) :: it type(quantum_numbers_t), dimension(:), intent(in) :: qn logical, intent(in), optional :: match_only_flavor type(quantum_numbers_t), dimension(:), allocatable :: qn_hard, qn_tmp logical :: match_flv match_flv = .false.; if (present (match_only_flavor)) match_flv = .true. do while (it%is_valid ()) if (match_flv) then qn_tmp = it%get_quantum_numbers () qn_hard = pack (qn_tmp, qn_tmp%are_hard_process ()) if (all (qn .fmatch. qn_hard)) then return else call it%advance () end if else if (all (qn == it%get_quantum_numbers ())) then return else call it%advance () end if end if end do end subroutine state_iterator_go_to_qn @ %def state_iterator_go_to_qn @ Use the iterator to retrieve quantum-number information: <>= generic :: get_quantum_numbers => get_qn_multi, get_qn_slice, & get_qn_range, get_qn_single generic :: get_flavor => get_flv_multi, get_flv_slice, & get_flv_range, get_flv_single generic :: get_color => get_col_multi, get_col_slice, & get_col_range, get_col_single generic :: get_helicity => get_hel_multi, get_hel_slice, & get_hel_range, get_hel_single <>= procedure :: get_qn_multi => state_iterator_get_qn_multi procedure :: get_qn_slice => state_iterator_get_qn_slice procedure :: get_qn_range => state_iterator_get_qn_range procedure :: get_qn_single => state_iterator_get_qn_single procedure :: get_flv_multi => state_iterator_get_flv_multi procedure :: get_flv_slice => state_iterator_get_flv_slice procedure :: get_flv_range => state_iterator_get_flv_range procedure :: get_flv_single => state_iterator_get_flv_single procedure :: get_col_multi => state_iterator_get_col_multi procedure :: get_col_slice => state_iterator_get_col_slice procedure :: get_col_range => state_iterator_get_col_range procedure :: get_col_single => state_iterator_get_col_single procedure :: get_hel_multi => state_iterator_get_hel_multi procedure :: get_hel_slice => state_iterator_get_hel_slice procedure :: get_hel_range => state_iterator_get_hel_range procedure :: get_hel_single => state_iterator_get_hel_single @ These versions return the whole quantum number array <>= function state_iterator_get_qn_multi (it) result (qn) class(state_iterator_t), intent(in) :: it type(quantum_numbers_t), dimension(it%depth) :: qn type(node_t), pointer :: node integer :: i node => it%node do i = it%depth, 1, -1 qn(i) = node%qn node => node%parent end do end function state_iterator_get_qn_multi function state_iterator_get_flv_multi (it) result (flv) class(state_iterator_t), intent(in) :: it type(flavor_t), dimension(it%depth) :: flv flv = quantum_numbers_get_flavor & (it%get_quantum_numbers ()) end function state_iterator_get_flv_multi function state_iterator_get_col_multi (it) result (col) class(state_iterator_t), intent(in) :: it type(color_t), dimension(it%depth) :: col col = quantum_numbers_get_color & (it%get_quantum_numbers ()) end function state_iterator_get_col_multi function state_iterator_get_hel_multi (it) result (hel) class(state_iterator_t), intent(in) :: it type(helicity_t), dimension(it%depth) :: hel hel = quantum_numbers_get_helicity & (it%get_quantum_numbers ()) end function state_iterator_get_hel_multi @ An array slice (derived from the above). <>= function state_iterator_get_qn_slice (it, index) result (qn) class(state_iterator_t), intent(in) :: it integer, dimension(:), intent(in) :: index type(quantum_numbers_t), dimension(size(index)) :: qn type(quantum_numbers_t), dimension(it%depth) :: qn_tmp qn_tmp = state_iterator_get_qn_multi (it) qn = qn_tmp(index) end function state_iterator_get_qn_slice function state_iterator_get_flv_slice (it, index) result (flv) class(state_iterator_t), intent(in) :: it integer, dimension(:), intent(in) :: index type(flavor_t), dimension(size(index)) :: flv flv = quantum_numbers_get_flavor & (it%get_quantum_numbers (index)) end function state_iterator_get_flv_slice function state_iterator_get_col_slice (it, index) result (col) class(state_iterator_t), intent(in) :: it integer, dimension(:), intent(in) :: index type(color_t), dimension(size(index)) :: col col = quantum_numbers_get_color & (it%get_quantum_numbers (index)) end function state_iterator_get_col_slice function state_iterator_get_hel_slice (it, index) result (hel) class(state_iterator_t), intent(in) :: it integer, dimension(:), intent(in) :: index type(helicity_t), dimension(size(index)) :: hel hel = quantum_numbers_get_helicity & (it%get_quantum_numbers (index)) end function state_iterator_get_hel_slice @ An array range (implemented directly). <>= function state_iterator_get_qn_range (it, k1, k2) result (qn) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k1, k2 type(quantum_numbers_t), dimension(k2-k1+1) :: qn type(node_t), pointer :: node integer :: i node => it%node SCAN: do i = it%depth, 1, -1 if (k1 <= i .and. i <= k2) then qn(i-k1+1) = node%qn else node => node%parent end if end do SCAN end function state_iterator_get_qn_range function state_iterator_get_flv_range (it, k1, k2) result (flv) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k1, k2 type(flavor_t), dimension(k2-k1+1) :: flv flv = quantum_numbers_get_flavor & (it%get_quantum_numbers (k1, k2)) end function state_iterator_get_flv_range function state_iterator_get_col_range (it, k1, k2) result (col) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k1, k2 type(color_t), dimension(k2-k1+1) :: col col = quantum_numbers_get_color & (it%get_quantum_numbers (k1, k2)) end function state_iterator_get_col_range function state_iterator_get_hel_range (it, k1, k2) result (hel) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k1, k2 type(helicity_t), dimension(k2-k1+1) :: hel hel = quantum_numbers_get_helicity & (it%get_quantum_numbers (k1, k2)) end function state_iterator_get_hel_range @ Just a specific single element <>= function state_iterator_get_qn_single (it, k) result (qn) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k type(quantum_numbers_t) :: qn type(node_t), pointer :: node integer :: i node => it%node SCAN: do i = it%depth, 1, -1 if (i == k) then qn = node%qn exit SCAN else node => node%parent end if end do SCAN end function state_iterator_get_qn_single function state_iterator_get_flv_single (it, k) result (flv) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k type(flavor_t) :: flv flv = quantum_numbers_get_flavor & (it%get_quantum_numbers (k)) end function state_iterator_get_flv_single function state_iterator_get_col_single (it, k) result (col) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k type(color_t) :: col col = quantum_numbers_get_color & (it%get_quantum_numbers (k)) end function state_iterator_get_col_single function state_iterator_get_hel_single (it, k) result (hel) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k type(helicity_t) :: hel hel = quantum_numbers_get_helicity & (it%get_quantum_numbers (k)) end function state_iterator_get_hel_single @ %def state_iterator_get_quantum_numbers @ %def state_iterator_get_flavor @ %def state_iterator_get_color @ %def state_iterator_get_helicity @ Assign a model pointer to the current flavor entries. <>= procedure :: set_model => state_iterator_set_model <>= subroutine state_iterator_set_model (it, model) class(state_iterator_t), intent(inout) :: it class(model_data_t), intent(in), target :: model type(node_t), pointer :: node integer :: i node => it%node do i = it%depth, 1, -1 call node%qn%set_model (model) node => node%parent end do end subroutine state_iterator_set_model @ %def state_iterator_set_model @ Retrieve the matrix element value associated with the current node. <>= procedure :: get_matrix_element => state_iterator_get_matrix_element <>= function state_iterator_get_matrix_element (it) result (me) complex(default) :: me class(state_iterator_t), intent(in) :: it if (it%state%leaf_nodes_store_values) then me = it%node%me else if (it%node%me_index /= 0) then me = it%state%me(it%node%me_index) else me = 0 end if end function state_iterator_get_matrix_element @ %def state_iterator_get_matrix_element @ Set the matrix element value using the state iterator. <>= procedure :: set_matrix_element => state_iterator_set_matrix_element <>= subroutine state_iterator_set_matrix_element (it, value) class(state_iterator_t), intent(inout) :: it complex(default), intent(in) :: value if (it%node%me_index /= 0) it%state%me(it%node%me_index) = value end subroutine state_iterator_set_matrix_element @ %def state_iterator_set_matrix_element @ <>= procedure :: add_to_matrix_element => state_iterator_add_to_matrix_element <>= subroutine state_iterator_add_to_matrix_element (it, value) class(state_iterator_t), intent(inout) :: it complex(default), intent(in) :: value if (it%node%me_index /= 0) & it%state%me(it%node%me_index) = it%state%me(it%node%me_index) + value end subroutine state_iterator_add_to_matrix_element @ %def state_iterator_add_to_matrix_element @ \subsection{Operations on quantum states} Return a deep copy of a state matrix. <>= public :: assignment(=) <>= interface assignment(=) module procedure state_matrix_assign end interface <>= subroutine state_matrix_assign (state_out, state_in) type(state_matrix_t), intent(out) :: state_out type(state_matrix_t), intent(in), target :: state_in type(state_iterator_t) :: it if (.not. state_in%is_defined ()) return call state_out%init () call it%init (state_in) do while (it%is_valid ()) call state_out%add_state (it%get_quantum_numbers (), & it%get_me_index ()) call it%advance () end do if (allocated (state_in%me)) then allocate (state_out%me (size (state_in%me))) state_out%me = state_in%me end if state_out%n_sub = state_in%n_sub end subroutine state_matrix_assign @ %def state_matrix_assign @ Determine the indices of all diagonal matrix elements. <>= procedure :: get_diagonal_entries => state_matrix_get_diagonal_entries <>= subroutine state_matrix_get_diagonal_entries (state, i) class(state_matrix_t), intent(in) :: state integer, dimension(:), allocatable, intent(out) :: i integer, dimension(state%n_matrix_elements) :: tmp integer :: n type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn n = 0 call it%init (state) allocate (qn (it%depth)) do while (it%is_valid ()) qn = it%get_quantum_numbers () if (all (qn%are_diagonal ())) then n = n + 1 tmp(n) = it%get_me_index () end if call it%advance () end do allocate (i(n)) if (n > 0) i = tmp(:n) end subroutine state_matrix_get_diagonal_entries @ %def state_matrices_get_diagonal_entries @ Normalize all matrix elements, i.e., multiply by a common factor. Assuming that the factor is nonzero, of course. <>= procedure :: renormalize => state_matrix_renormalize <>= subroutine state_matrix_renormalize (state, factor) class(state_matrix_t), intent(inout) :: state complex(default), intent(in) :: factor state%me = state%me * factor end subroutine state_matrix_renormalize @ %def state_matrix_renormalize @ Renormalize the state matrix by its trace, if nonzero. The renormalization is reflected in the state-matrix norm. <>= procedure :: normalize_by_trace => state_matrix_normalize_by_trace <>= subroutine state_matrix_normalize_by_trace (state) class(state_matrix_t), intent(inout) :: state real(default) :: trace trace = state%trace () if (trace /= 0) then state%me = state%me / trace state%norm = state%norm * trace end if end subroutine state_matrix_normalize_by_trace @ %def state_matrix_renormalize_by_trace @ Analogous, but renormalize by maximal (absolute) value. <>= procedure :: normalize_by_max => state_matrix_normalize_by_max <>= subroutine state_matrix_normalize_by_max (state) class(state_matrix_t), intent(inout) :: state real(default) :: m m = maxval (abs (state%me)) if (m /= 0) then state%me = state%me / m state%norm = state%norm * m end if end subroutine state_matrix_normalize_by_max @ %def state_matrix_renormalize_by_max @ Explicitly set the norm of a state matrix. <>= procedure :: set_norm => state_matrix_set_norm <>= subroutine state_matrix_set_norm (state, norm) class(state_matrix_t), intent(inout) :: state real(default), intent(in) :: norm state%norm = norm end subroutine state_matrix_set_norm @ %def state_matrix_set_norm @ Return the sum of all matrix element values. <>= procedure :: sum => state_matrix_sum <>= pure function state_matrix_sum (state) result (value) complex(default) :: value class(state_matrix_t), intent(in) :: state value = sum (state%me) end function state_matrix_sum @ %def state_matrix_sum @ Return the trace of a state matrix, i.e., the sum over all diagonal values. If [[qn_in]] is provided, only branches that match this quantum-numbers array in flavor and helicity are considered. (This mode is used for selecting a color state.) <>= procedure :: trace => state_matrix_trace <>= function state_matrix_trace (state, qn_in) result (trace) complex(default) :: trace class(state_matrix_t), intent(in), target :: state type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in type(quantum_numbers_t), dimension(:), allocatable :: qn type(state_iterator_t) :: it allocate (qn (state%get_depth ())) trace = 0 call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () if (present (qn_in)) then if (.not. all (qn .fhmatch. qn_in)) then call it%advance (); cycle end if end if if (all (qn%are_diagonal ())) then trace = trace + it%get_matrix_element () end if call it%advance () end do end function state_matrix_trace @ %def state_matrix_trace @ Append new states which are color-contracted versions of the existing states. The matrix element index of each color contraction coincides with the index of its origin, so no new matrix elements are generated. After this operation, no [[freeze]] must be performed anymore. <>= procedure :: add_color_contractions => state_matrix_add_color_contractions <>= subroutine state_matrix_add_color_contractions (state) class(state_matrix_t), intent(inout), target :: state type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:,:), allocatable :: qn type(quantum_numbers_t), dimension(:,:), allocatable :: qn_con integer, dimension(:), allocatable :: me_index integer :: depth, n_me, i, j depth = state%get_depth () n_me = state%get_n_matrix_elements () allocate (qn (depth, n_me)) allocate (me_index (n_me)) i = 0 call it%init (state) do while (it%is_valid ()) i = i + 1 qn(:,i) = it%get_quantum_numbers () me_index(i) = it%get_me_index () call it%advance () end do do i = 1, n_me call quantum_number_array_make_color_contractions (qn(:,i), qn_con) do j = 1, size (qn_con, 2) call state%add_state (qn_con(:,j), index = me_index(i)) end do end do end subroutine state_matrix_add_color_contractions @ %def state_matrix_add_color_contractions @ This procedure merges two state matrices of equal depth. For each quantum number (flavor, color, helicity), we take the entry from the first argument where defined, otherwise the second one. (If both are defined, we get an off-diagonal matrix.) The resulting trie combines the information of the input tries in all possible ways. Note that values are ignored, all values in the result are zero. <>= public :: merge_state_matrices <>= subroutine merge_state_matrices (state1, state2, state3) type(state_matrix_t), intent(in), target :: state1, state2 type(state_matrix_t), intent(out) :: state3 type(state_iterator_t) :: it1, it2 type(quantum_numbers_t), dimension(state1%depth) :: qn1, qn2 if (state1%depth /= state2%depth) then call state1%write () call state2%write () call msg_bug ("State matrices merge impossible: incompatible depths") end if call state3%init () call it1%init (state1) do while (it1%is_valid ()) qn1 = it1%get_quantum_numbers () call it2%init (state2) do while (it2%is_valid ()) qn2 = it2%get_quantum_numbers () call state3%add_state (qn1 .merge. qn2) call it2%advance () end do call it1%advance () end do call state3%freeze () end subroutine merge_state_matrices @ %def merge_state_matrices @ Multiply matrix elements from two state matrices. Choose the elements as given by the integer index arrays, multiply them and store the sum of products in the indicated matrix element. The suffixes mean: c=conjugate first factor; f=include weighting factor. Note that the [[dot_product]] intrinsic function conjugates its first complex argument. This is intended for the [[c]] suffix case, but must be reverted for the plain-product case. We provide analogous subroutines for just summing over state matrix entries. The [[evaluate_sum]] variant includes the state-matrix norm in the evaluation, the [[evaluate_me_sum]] takes into account just the matrix elements proper. <>= procedure :: evaluate_product => state_matrix_evaluate_product procedure :: evaluate_product_cf => state_matrix_evaluate_product_cf procedure :: evaluate_square_c => state_matrix_evaluate_square_c procedure :: evaluate_sum => state_matrix_evaluate_sum procedure :: evaluate_me_sum => state_matrix_evaluate_me_sum <>= pure subroutine state_matrix_evaluate_product & (state, i, state1, state2, index1, index2) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1, state2 integer, dimension(:), intent(in) :: index1, index2 state%me(i) = & dot_product (conjg (state1%me(index1)), state2%me(index2)) state%norm = state1%norm * state2%norm end subroutine state_matrix_evaluate_product pure subroutine state_matrix_evaluate_product_cf & (state, i, state1, state2, index1, index2, factor) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1, state2 integer, dimension(:), intent(in) :: index1, index2 complex(default), dimension(:), intent(in) :: factor state%me(i) = & dot_product (state1%me(index1), factor * state2%me(index2)) state%norm = state1%norm * state2%norm end subroutine state_matrix_evaluate_product_cf pure subroutine state_matrix_evaluate_square_c (state, i, state1, index1) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1 integer, dimension(:), intent(in) :: index1 state%me(i) = & dot_product (state1%me(index1), state1%me(index1)) state%norm = abs (state1%norm) ** 2 end subroutine state_matrix_evaluate_square_c pure subroutine state_matrix_evaluate_sum (state, i, state1, index1) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1 integer, dimension(:), intent(in) :: index1 state%me(i) = & sum (state1%me(index1)) * state1%norm end subroutine state_matrix_evaluate_sum pure subroutine state_matrix_evaluate_me_sum (state, i, state1, index1) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1 integer, dimension(:), intent(in) :: index1 state%me(i) = sum (state1%me(index1)) end subroutine state_matrix_evaluate_me_sum @ %def state_matrix_evaluate_product @ %def state_matrix_evaluate_product_cf @ %def state_matrix_evaluate_square_c @ %def state_matrix_evaluate_sum @ %def state_matrix_evaluate_me_sum @ Outer product (of states and matrix elements): <>= public :: outer_multiply <>= interface outer_multiply module procedure outer_multiply_pair module procedure outer_multiply_array end interface @ %def outer_multiply @ This procedure constructs the outer product of two state matrices. <>= subroutine outer_multiply_pair (state1, state2, state3) type(state_matrix_t), intent(in), target :: state1, state2 type(state_matrix_t), intent(out) :: state3 type(state_iterator_t) :: it1, it2 type(quantum_numbers_t), dimension(state1%depth) :: qn1 type(quantum_numbers_t), dimension(state2%depth) :: qn2 type(quantum_numbers_t), dimension(state1%depth+state2%depth) :: qn3 complex(default) :: val1, val2 call state3%init (store_values = .true.) call it1%init (state1) do while (it1%is_valid ()) qn1 = it1%get_quantum_numbers () val1 = it1%get_matrix_element () call it2%init (state2) do while (it2%is_valid ()) qn2 = it2%get_quantum_numbers () val2 = it2%get_matrix_element () qn3(:state1%depth) = qn1 qn3(state1%depth+1:) = qn2 call state3%add_state (qn3, value=val1 * val2) call it2%advance () end do call it1%advance () end do call state3%freeze () end subroutine outer_multiply_pair @ %def outer_multiply_state_pair @ This executes the above routine iteratively for an arbitrary number of state matrices. <>= subroutine outer_multiply_array (state_in, state_out) type(state_matrix_t), dimension(:), intent(in), target :: state_in type(state_matrix_t), intent(out) :: state_out type(state_matrix_t), dimension(:), allocatable, target :: state_tmp integer :: i, n n = size (state_in) select case (n) case (0) call state_out%init () case (1) state_out = state_in(1) case (2) call outer_multiply_pair (state_in(1), state_in(2), state_out) case default allocate (state_tmp (n-2)) call outer_multiply_pair (state_in(1), state_in(2), state_tmp(1)) do i = 2, n - 2 call outer_multiply_pair (state_tmp(i-1), state_in(i+1), state_tmp(i)) end do call outer_multiply_pair (state_tmp(n-2), state_in(n), state_out) do i = 1, size(state_tmp) call state_tmp(i)%final () end do end select end subroutine outer_multiply_array @ %def outer_multiply_pair @ %def outer_multiply_array @ \subsection{Factorization} In physical events, the state matrix is factorized into single-particle state matrices. This is essentially a measurement. In a simulation, we select one particular branch of the state matrix with a probability that is determined by the matrix elements at the leaves. (This makes sense only if the state matrix represents a squared amplitude.) The selection is based on a (random) value [[x]] between 0 and one that is provided as the third argument. For flavor and color, we select a unique value for each particle. For polarization, we have three options (modes). Option 1 is to drop helicity information altogether and sum over all diagonal helicities. Option 2 is to select a unique diagonal helicity in the same way as flavor and color. Option 3 is, for each particle, to trace over all remaining helicities in order to obtain an array of independent single-particle helicity matrices. Only branches that match the given quantum-number array [[qn_in]], if present, are considered. For this array, color is ignored. If the optional [[correlated_state]] is provided, it is assigned the correlated density matrix for the selected flavor-color branch, so multi-particle spin correlations remain available even if they are dropped in the single-particle density matrices. This should be done by the caller for the choice [[FM_CORRELATED_HELICITY]], which otherwise is handled as [[FM_IGNORE_HELICITY]]. The algorithm is as follows: First, we determine the normalization by summing over all diagonal matrix elements. In a second scan, we select one of the diagonal matrix elements by a cumulative comparison with the normalized random number. In the corresponding quantum number array, we undefine the helicity entries. Then, we scan the third time. For each branch that matches the selected quantum number array (i.e., definite flavor and color, arbitrary helicity), we determine its contribution to any of the single-particle state matrices. The matrix-element value is added if all other quantum numbers are diagonal, while the helicity of the chosen particle may be arbitrary; this helicity determines the branch in the single-particle state. As a result, flavor and color quantum numbers are selected with the correct probability. Within this subset of states, each single-particle state matrix results from tracing over all other particles. Note that the single-particle state matrices are not normalized. The flag [[ok]] is set to false if the matrix element sum is zero, so factorization is not possible. This can happen if an event did not pass cuts. <>= integer, parameter, public :: FM_IGNORE_HELICITY = 1 integer, parameter, public :: FM_SELECT_HELICITY = 2 integer, parameter, public :: FM_FACTOR_HELICITY = 3 integer, parameter, public :: FM_CORRELATED_HELICITY = 4 @ %def FM_IGNORE_HELICITY FM_SELECT_HELICITY FM_FACTOR_HELICITY @ %def FM_CORRELATED_HELICITY <>= procedure :: factorize => state_matrix_factorize <>= subroutine state_matrix_factorize & (state, mode, x, ok, single_state, correlated_state, qn_in) class(state_matrix_t), intent(in), target :: state integer, intent(in) :: mode real(default), intent(in) :: x logical, intent(out) :: ok type(state_matrix_t), & dimension(:), allocatable, intent(out) :: single_state type(state_matrix_t), intent(out), optional :: correlated_state type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in type(state_iterator_t) :: it real(default) :: s, xt complex(default) :: value integer :: i, depth type(quantum_numbers_t), dimension(:), allocatable :: qn, qn1 type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask logical, dimension(:), allocatable :: diagonal logical, dimension(:,:), allocatable :: mask ok = .true. if (x /= 0) then xt = x * abs (state%trace (qn_in)) else xt = 0 end if s = 0 depth = state%get_depth () allocate (qn (depth), qn1 (depth), diagonal (depth)) call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () if (present (qn_in)) then if (.not. all (qn .fhmatch. qn_in)) then call it%advance (); cycle end if end if if (all (qn%are_diagonal ())) then value = abs (it%get_matrix_element ()) s = s + value if (s > xt) exit end if call it%advance () end do if (.not. it%is_valid ()) then if (s == 0) ok = .false. call it%init (state) end if allocate (single_state (depth)) do i = 1, depth call single_state(i)%init (store_values = .true.) end do if (present (correlated_state)) & call correlated_state%init (store_values = .true.) qn = it%get_quantum_numbers () select case (mode) case (FM_SELECT_HELICITY) ! single branch selected; shortcut do i = 1, depth call single_state(i)%add_state ([qn(i)], value=value) end do if (.not. present (correlated_state)) then do i = 1, size(single_state) call single_state(i)%freeze () end do return end if end select allocate (qn_mask (depth)) call qn_mask%init (.false., .false., .false., .true.) call qn%undefine (qn_mask) select case (mode) case (FM_FACTOR_HELICITY) allocate (mask (depth, depth)) mask = .false. forall (i = 1:depth) mask(i,i) = .true. end select call it%init (state) do while (it%is_valid ()) qn1 = it%get_quantum_numbers () if (all (qn .match. qn1)) then diagonal = qn1%are_diagonal () value = it%get_matrix_element () select case (mode) case (FM_IGNORE_HELICITY, FM_CORRELATED_HELICITY) !!! trace over diagonal states that match qn if (all (diagonal)) then do i = 1, depth call single_state(i)%add_state & ([qn(i)], value=value, sum_values=.true.) end do end if case (FM_FACTOR_HELICITY) !!! trace over all other particles do i = 1, depth if (all (diagonal .or. mask(:,i))) then call single_state(i)%add_state & ([qn1(i)], value=value, sum_values=.true.) end if end do end select if (present (correlated_state)) & call correlated_state%add_state (qn1, value=value) end if call it%advance () end do do i = 1, depth call single_state(i)%freeze () end do if (present (correlated_state)) & call correlated_state%freeze () end subroutine state_matrix_factorize @ %def state_matrix_factorize @ \subsubsection{Auxiliary functions} <>= procedure :: get_polarization_density_matrix & => state_matrix_get_polarization_density_matrix <>= function state_matrix_get_polarization_density_matrix (state) result (pol_matrix) real(default), dimension(:,:), allocatable :: pol_matrix class(state_matrix_t), intent(in) :: state type(node_t), pointer :: current => null () !!! What's the generic way to allocate the matrix? allocate (pol_matrix (4,4)); pol_matrix = 0 if (associated (state%root%child_first)) then current => state%root%child_first do while (associated (current)) call current%qn%write () current => current%next end do else call msg_fatal ("Polarization state not allocated!") end if end function state_matrix_get_polarization_density_matrix @ %def state_matrix_get_polarization_density_matrix @ \subsubsection{Quantum-number matching} This feature allows us to check whether a given string of PDG values matches, in any ordering, any of the flavor combinations that the state matrix provides. We will also request the permutation of the successful match. This type provides an account of the state's flavor content. We store all flavor combinations, as [[pdg]] values, in an array, assuming that the length is uniform. We check only the entries selected by [[mask_match]]. Among those, only the entries selected by [[mask_sort]] are sorted and thus matched without respecting array element order. The entries that correspond to a true value in the associated [[mask]] are sorted. The mapping from the original state to the sorted state is given by the index array [[map]]. <>= public :: state_flv_content_t <>= type :: state_flv_content_t private integer, dimension(:,:), allocatable :: pdg integer, dimension(:,:), allocatable :: map logical, dimension(:), allocatable :: mask contains <> end type state_flv_content_t @ %def state_matrix_flavor_content @ Output (debugging aid). <>= procedure :: write => state_flv_content_write <>= subroutine state_flv_content_write (state_flv, unit) class(state_flv_content_t), intent(in), target :: state_flv integer, intent(in), optional :: unit integer :: u, n, d, i, j u = given_output_unit (unit) d = size (state_flv%pdg, 1) n = size (state_flv%pdg, 2) do i = 1, n write (u, "(2x,'PDG =')", advance="no") do j = 1, d write (u, "(1x,I0)", advance="no") state_flv%pdg(j,i) end do write (u, "(' :: map = (')", advance="no") do j = 1, d write (u, "(1x,I0)", advance="no") state_flv%map(j,i) end do write (u, "(' )')") end do end subroutine state_flv_content_write @ %def state_flv_content_write @ Initialize with table length and mask. Each row of the [[map]] array, of length $d$, is initialized with $(0,1,\ldots,d)$. <>= procedure :: init => state_flv_content_init <>= subroutine state_flv_content_init (state_flv, n, mask) class(state_flv_content_t), intent(out) :: state_flv integer, intent(in) :: n logical, dimension(:), intent(in) :: mask integer :: d, i d = size (mask) allocate (state_flv%pdg (d, n), source = 0) allocate (state_flv%map (d, n), source = spread ([(i, i = 1, d)], 2, n)) allocate (state_flv%mask (d), source = mask) end subroutine state_flv_content_init @ %def state_flv_content_init @ Manually fill the entries, one flavor set and mapping at a time. <>= procedure :: set_entry => state_flv_content_set_entry <>= subroutine state_flv_content_set_entry (state_flv, i, pdg, map) class(state_flv_content_t), intent(inout) :: state_flv integer, intent(in) :: i integer, dimension(:), intent(in) :: pdg, map state_flv%pdg(:,i) = pdg where (map /= 0) state_flv%map(:,i) = map end where end subroutine state_flv_content_set_entry @ %def state_flv_content_set_entry @ Given a state matrix, determine the flavor content. That is, scan the state matrix and extract flavor only, build a new state matrix from that. <>= procedure :: fill => state_flv_content_fill <>= subroutine state_flv_content_fill & (state_flv, state_full, mask) class(state_flv_content_t), intent(out) :: state_flv type(state_matrix_t), intent(in), target :: state_full logical, dimension(:), intent(in) :: mask type(state_matrix_t), target :: state_tmp type(state_iterator_t) :: it type(flavor_t), dimension(:), allocatable :: flv integer, dimension(:), allocatable :: pdg, pdg_subset integer, dimension(:), allocatable :: idx, map_subset, idx_subset, map type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: n, d, c, i, j call state_tmp%init () d = state_full%get_depth () allocate (flv (d), qn (d), pdg (d), idx (d), map (d)) idx = [(i, i = 1, d)] c = count (mask) allocate (pdg_subset (c), map_subset (c), idx_subset (c)) call it%init (state_full) do while (it%is_valid ()) flv = it%get_flavor () call qn%init (flv) call state_tmp%add_state (qn) call it%advance () end do n = state_tmp%get_n_leaves () call state_flv%init (n, mask) i = 0 call it%init (state_tmp) do while (it%is_valid ()) i = i + 1 flv = it%get_flavor () pdg = flv%get_pdg () idx_subset = pack (idx, mask) pdg_subset = pack (pdg, mask) map_subset = order_abs (pdg_subset) map = unpack (idx_subset (map_subset), mask, idx) call state_flv%set_entry (i, & unpack (pdg_subset(map_subset), mask, pdg), & order (map)) call it%advance () end do call state_tmp%final () end subroutine state_flv_content_fill @ %def state_flv_content_fill @ Match a given flavor string against the flavor content. We sort the input string and check whether it matches any of the stored strings. If yes, return the mapping. Only PDG entries under the preset mask are sorted before matching. The other entries must match exactly (i.e., without reordering). A zero entry matches anything. In any case, the length of the PDG string must be equal to the length $d$ of the individual flavor-state entries. <>= procedure :: match => state_flv_content_match <>= subroutine state_flv_content_match (state_flv, pdg, success, map) class(state_flv_content_t), intent(in) :: state_flv integer, dimension(:), intent(in) :: pdg logical, intent(out) :: success integer, dimension(:), intent(out) :: map integer, dimension(:), allocatable :: pdg_subset, pdg_sorted, map1, map2 integer, dimension(:), allocatable :: idx, map_subset, idx_subset integer :: i, n, c, d c = count (state_flv%mask) d = size (state_flv%pdg, 1) n = size (state_flv%pdg, 2) allocate (idx (d), source = [(i, i = 1, d)]) allocate (idx_subset (c), pdg_subset (c), map_subset (c)) allocate (pdg_sorted (d), map1 (d), map2 (d)) idx_subset = pack (idx, state_flv%mask) pdg_subset = pack (pdg, state_flv%mask) map_subset = order_abs (pdg_subset) pdg_sorted = unpack (pdg_subset(map_subset), state_flv%mask, pdg) success = .false. do i = 1, n if (all (pdg_sorted == state_flv%pdg(:,i) & .or. pdg_sorted == 0)) then success = .true. exit end if end do if (success) then map1 = state_flv%map(:,i) map2 = unpack (idx_subset(map_subset), state_flv%mask, idx) map = map2(map1) where (pdg == 0) map = 0 end if end subroutine state_flv_content_match @ %def state_flv_content_match @ <>= elemental function pacify_complex (c_in) result (c_pac) complex(default), intent(in) :: c_in complex(default) :: c_pac c_pac = c_in if (real(c_pac) == -real(c_pac)) then c_pac = & cmplx (0._default, aimag(c_pac), kind=default) end if if (aimag(c_pac) == -aimag(c_pac)) then c_pac = & cmplx (real(c_pac), 0._default, kind=default) end if end function pacify_complex @ %def pacify_complex @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[state_matrices_ut.f90]]>>= <> module state_matrices_ut use unit_tests use state_matrices_uti <> <> contains <> end module state_matrices_ut @ %def state_matrices_ut @ <<[[state_matrices_uti.f90]]>>= <> module state_matrices_uti <> use io_units use format_defs, only: FMT_19 use flavors use colors use helicities use quantum_numbers use state_matrices <> <> contains <> end module state_matrices_uti @ %def state_matrices_ut @ API: driver for the unit tests below. <>= public :: state_matrix_test <>= subroutine state_matrix_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine state_matrix_test @ %def state_matrix_test @ Create two quantum states of equal depth and merge them. <>= call test (state_matrix_1, "state_matrix_1", & "check merge of quantum states of equal depth", & u, results) <>= public :: state_matrix_1 <>= subroutine state_matrix_1 (u) integer, intent(in) :: u type(state_matrix_t) :: state1, state2, state3 type(flavor_t), dimension(3) :: flv type(color_t), dimension(3) :: col type(quantum_numbers_t), dimension(3) :: qn write (u, "(A)") "* Test output: state_matrix_1" write (u, "(A)") "* Purpose: create and merge two quantum states" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") write (u, "(A)") "* State matrix 1" write (u, "(A)") call state1%init () call flv%init ([1, 2, 11]) call qn%init (flv, helicity ([ 1, 1, 1])) call state1%add_state (qn) call qn%init (flv, helicity ([ 1, 1, 1], [-1, 1, -1])) call state1%add_state (qn) call state1%freeze () call state1%write (u) write (u, "(A)") write (u, "(A)") "* State matrix 2" write (u, "(A)") call state2%init () call col(1)%init ([501]) call col(2)%init ([-501]) call col(3)%init ([0]) call qn%init (col, helicity ([-1, -1, 0])) call state2%add_state (qn) call col(3)%init ([99]) call qn%init (col, helicity ([-1, -1, 0])) call state2%add_state (qn) call state2%freeze () call state2%write (u) write (u, "(A)") write (u, "(A)") "* Merge the state matrices" write (u, "(A)") call merge_state_matrices (state1, state2, state3) call state3%write (u) write (u, "(A)") write (u, "(A)") "* Collapse the state matrix" write (u, "(A)") call state3%collapse (quantum_numbers_mask (.false., .false., & [.true.,.false.,.false.])) call state3%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call state1%final () call state2%final () call state3%final () write (u, "(A)") write (u, "(A)") "* Test output end: state_matrix_1" write (u, "(A)") end subroutine state_matrix_1 @ %def state_matrix_1 @ Create a correlated three-particle state matrix and factorize it. <>= call test (state_matrix_2, "state_matrix_2", & "check factorizing 3-particle state matrix", & u, results) <>= public :: state_matrix_2 <>= subroutine state_matrix_2 (u) integer, intent(in) :: u type(state_matrix_t) :: state type(state_matrix_t), dimension(:), allocatable :: single_state type(state_matrix_t) :: correlated_state integer :: f, h11, h12, h21, h22, i, mode type(flavor_t), dimension(2) :: flv type(color_t), dimension(2) :: col type(helicity_t), dimension(2) :: hel type(quantum_numbers_t), dimension(2) :: qn logical :: ok write (u, "(A)") write (u, "(A)") "* Test output: state_matrix_2" write (u, "(A)") "* Purpose: factorize correlated 3-particle state" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call state%init () do f = 1, 2 do h11 = -1, 1, 2 do h12 = -1, 1, 2 do h21 = -1, 1, 2 do h22 = -1, 1, 2 call flv%init ([f, -f]) call col(1)%init ([1]) call col(2)%init ([-1]) call hel%init ([h11,h12], [h21, h22]) call qn%init (flv, col, hel) call state%add_state (qn) end do end do end do end do end do call state%freeze () call state%write (u) write (u, "(A)") write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") & "* Trace = ", state%trace () write (u, "(A)") do mode = 1, 3 write (u, "(A)") write (u, "(A,I1)") "* Mode = ", mode call state%factorize & (mode, 0.15_default, ok, single_state, correlated_state) do i = 1, size (single_state) write (u, "(A)") call single_state(i)%write (u) write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") & "Trace = ", single_state(i)%trace () end do write (u, "(A)") call correlated_state%write (u) write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") & "Trace = ", correlated_state%trace () do i = 1, size(single_state) call single_state(i)%final () end do call correlated_state%final () end do write (u, "(A)") write (u, "(A)") "* Cleanup" call state%final () write (u, "(A)") write (u, "(A)") "* Test output end: state_matrix_2" end subroutine state_matrix_2 @ %def state_matrix_2 @ Create a colored state matrix and add color contractions. <>= call test (state_matrix_3, "state_matrix_3", & "check factorizing 3-particle state matrix", & u, results) <>= public :: state_matrix_3 <>= subroutine state_matrix_3 (u) use physics_defs, only: HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET integer, intent(in) :: u type(state_matrix_t) :: state type(flavor_t), dimension(4) :: flv type(color_t), dimension(4) :: col type(quantum_numbers_t), dimension(4) :: qn write (u, "(A)") "* Test output: state_matrix_3" write (u, "(A)") "* Purpose: add color connections to colored state" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call state%init () call flv%init ([ 1, -HADRON_REMNANT_TRIPLET, -1, HADRON_REMNANT_TRIPLET ]) call col(1)%init ([17]) call col(2)%init ([-17]) call col(3)%init ([-19]) call col(4)%init ([19]) call qn%init (flv, col) call state%add_state (qn) call flv%init ([ 1, -HADRON_REMNANT_TRIPLET, 21, HADRON_REMNANT_OCTET ]) call col(1)%init ([17]) call col(2)%init ([-17]) call col(3)%init ([3, -5]) call col(4)%init ([5, -3]) call qn%init (flv, col) call state%add_state (qn) call state%freeze () write (u, "(A)") "* State:" write (u, "(A)") call state%write (u) call state%add_color_contractions () write (u, "(A)") "* State with contractions:" write (u, "(A)") call state%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call state%final () write (u, "(A)") write (u, "(A)") "* Test output end: state_matrx_3" end subroutine state_matrix_3 @ %def state_matrix_3 @ Create a correlated three-particle state matrix, write it to file and read again. <>= call test (state_matrix_4, "state_matrix_4", & "check raw I/O", & u, results) <>= public :: state_matrix_4 <>= subroutine state_matrix_4 (u) integer, intent(in) :: u type(state_matrix_t), allocatable :: state integer :: f, h11, h12, h21, h22, i type(flavor_t), dimension(2) :: flv type(color_t), dimension(2) :: col type(helicity_t), dimension(2) :: hel type(quantum_numbers_t), dimension(2) :: qn integer :: unit, iostat write (u, "(A)") write (u, "(A)") "* Test output: state_matrix_4" write (u, "(A)") "* Purpose: raw I/O for correlated 3-particle state" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") allocate (state) call state%init () do f = 1, 2 do h11 = -1, 1, 2 do h12 = -1, 1, 2 do h21 = -1, 1, 2 do h22 = -1, 1, 2 call flv%init ([f, -f]) call col(1)%init ([1]) call col(2)%init ([-1]) call hel%init ([h11, h12], [h21, h22]) call qn%init (flv, col, hel) call state%add_state (qn) end do end do end do end do end do call state%freeze () call state%set_norm (3._default) do i = 1, state%get_n_leaves () call state%set_matrix_element (i, cmplx (2 * i, 2 * i + 1, default)) end do call state%write (u) write (u, "(A)") write (u, "(A)") "* Write to file and read again " write (u, "(A)") unit = free_unit () open (unit, action="readwrite", form="unformatted", status="scratch") call state%write_raw (unit) call state%final () deallocate (state) allocate(state) rewind (unit) call state%read_raw (unit, iostat=iostat) close (unit) call state%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call state%final () deallocate (state) write (u, "(A)") write (u, "(A)") "* Test output end: state_matrix_4" end subroutine state_matrix_4 @ %def state_matrix_4 @ Create a flavor-content object for a given state matrix and match it against trial flavor (i.e., PDG) strings. <>= call test (state_matrix_5, "state_matrix_5", & "check flavor content", & u, results) <>= public :: state_matrix_5 <>= subroutine state_matrix_5 (u) integer, intent(in) :: u type(state_matrix_t), allocatable, target :: state type(state_iterator_t) :: it type(state_flv_content_t), allocatable :: state_flv type(flavor_t), dimension(4) :: flv1, flv2, flv3, flv4 type(color_t), dimension(4) :: col1, col2 type(helicity_t), dimension(4) :: hel1, hel2, hel3 type(quantum_numbers_t), dimension(4) :: qn logical, dimension(4) :: mask write (u, "(A)") "* Test output: state_matrix_5" write (u, "(A)") "* Purpose: check flavor-content state" write (u, "(A)") write (u, "(A)") "* Set up arbitrary state matrix" write (u, "(A)") call flv1%init ([1, 4, 2, 7]) call flv2%init ([1, 3,-3, 8]) call flv3%init ([5, 6, 3, 7]) call flv4%init ([6, 3, 5, 8]) call hel1%init ([0, 1, -1, 0]) call hel2%init ([0, 1, 1, 1]) call hel3%init ([1, 0, 0, 0]) call col1(1)%init ([0]) call col1(2)%init ([0]) call col1(3)%init ([0]) call col1(4)%init ([0]) call col2(1)%init ([5, -6]) call col2(2)%init ([0]) call col2(3)%init ([6, -5]) call col2(4)%init ([0]) allocate (state) call state%init () call qn%init (flv1, col1, hel1) call state%add_state (qn) call qn%init (flv1, col1, hel2) call state%add_state (qn) call qn%init (flv3, col1, hel3) call state%add_state (qn) call qn%init (flv4, col1, hel3) call state%add_state (qn) call qn%init (flv1, col2, hel3) call state%add_state (qn) call qn%init (flv2, col2, hel2) call state%add_state (qn) call qn%init (flv2, col2, hel1) call state%add_state (qn) call qn%init (flv2, col1, hel1) call state%add_state (qn) call qn%init (flv3, col1, hel1) call state%add_state (qn) call qn%init (flv3, col2, hel3) call state%add_state (qn) call qn%init (flv1, col1, hel1) call state%add_state (qn) write (u, "(A)") "* Quantum number content" write (u, "(A)") call it%init (state) do while (it%is_valid ()) call quantum_numbers_write (it%get_quantum_numbers (), u) write (u, *) call it%advance () end do write (u, "(A)") write (u, "(A)") "* Extract the flavor content" write (u, "(A)") mask = [.true., .true., .true., .false.] allocate (state_flv) call state_flv%fill (state, mask) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Match trial sets" write (u, "(A)") call check ([1, 2, 3, 0]) call check ([1, 4, 2, 0]) call check ([4, 2, 1, 0]) call check ([1, 3, -3, 0]) call check ([1, -3, 3, 0]) call check ([6, 3, 5, 0]) write (u, "(A)") write (u, "(A)") "* Determine the flavor content with mask" write (u, "(A)") mask = [.false., .true., .true., .false.] call state_flv%fill (state, mask) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Match trial sets" write (u, "(A)") call check ([1, 2, 3, 0]) call check ([1, 4, 2, 0]) call check ([4, 2, 1, 0]) call check ([1, 3, -3, 0]) call check ([1, -3, 3, 0]) call check ([6, 3, 5, 0]) write (u, "(A)") write (u, "(A)") "* Cleanup" deallocate (state_flv) call state%final () deallocate (state) write (u, "(A)") write (u, "(A)") "* Test output end: state_matrix_5" contains subroutine check (pdg) integer, dimension(4), intent(in) :: pdg integer, dimension(4) :: map logical :: success call state_flv%match (pdg, success, map) write (u, "(2x,4(1x,I0),':',1x,L1)", advance="no") pdg, success if (success) then write (u, "(2x,'map = (',4(1x,I0),' )')") map else write (u, *) end if end subroutine check end subroutine state_matrix_5 @ %def state_matrix_5 @ Create a state matrix with full flavor, color and helicity information. Afterwards, reduce such that it is only differential in flavor and initial-state helicities. This is used when preparing states for beam- polarized computations with external matrix element providers. <>= call test (state_matrix_6, "state_matrix_6", & "check state matrix reduction", & u, results) <>= public :: state_matrix_6 <>= subroutine state_matrix_6 (u) integer, intent(in) :: u type(state_matrix_t), allocatable :: state_orig, state_reduced type(flavor_t), dimension(4) :: flv type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col type(quantum_numbers_t), dimension(4) :: qn type(quantum_numbers_mask_t), dimension(4) :: qn_mask integer :: h1, h2, h3 , h4 integer :: n_states = 0 write (u, "(A)") "* Test output: state_matrix_6" write (u, "(A)") "* Purpose: Check state matrix reduction" write (u, "(A)") write (u, "(A)") "* Set up helicity-diagonal state matrix" write (u, "(A)") allocate (state_orig) call state_orig%init () call flv%init ([11, -11, 1, -1]) call col(3)%init ([1]) call col(4)%init ([-1]) do h1 = -1, 1, 2 do h2 = -1, 1, 2 do h3 = -1, 1, 2 do h4 = -1, 1, 2 n_states = n_states + 1 call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4]) call qn%init (flv, col, hel) call state_orig%add_state (qn) end do end do end do end do call state_orig%freeze () write (u, "(A)") "* Original state: " write (u, "(A)") call state_orig%write (u) write (u, "(A)") write (u, "(A)") "* Setup quantum mask: " call qn_mask%init ([.false., .false., .false., .false.], & [.true., .true., .true., .true.], & [.false., .false., .true., .true.]) call quantum_numbers_mask_write (qn_mask, u) write (u, "(A)") write (u, "(A)") "* Reducing the state matrix using above mask" write (u, "(A)") allocate (state_reduced) call state_orig%reduce (qn_mask, state_reduced) write (u, "(A)") "* Reduced state matrix: " call state_reduced%write (u) write (u, "(A)") "* Test output end: state_matrix_6" end subroutine state_matrix_6 @ %def state_matrix_6 @ Create a state matrix with full flavor, color and helicity information. Afterwards, reduce such that it is only differential in flavor and initial-state helicities, and keeping old indices. Afterwards reorder the reduced state matrix in accordance to the original state matrix. <>= call test (state_matrix_7, "state_matrix_7", & "check ordered state matrix reduction", & u, results) <>= public :: state_matrix_7 <>= subroutine state_matrix_7 (u) integer, intent(in) :: u type(state_matrix_t), allocatable :: state_orig, state_reduced, & state_ordered type(flavor_t), dimension(4) :: flv type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col type(quantum_numbers_t), dimension(4) :: qn type(quantum_numbers_mask_t), dimension(4) :: qn_mask integer :: h1, h2, h3 , h4 integer :: n_states = 0 write (u, "(A)") "* Test output: state_matrix_7" write (u, "(A)") "* Purpose: Check ordered state matrix reduction" write (u, "(A)") write (u, "(A)") "* Set up helicity-diagonal state matrix" write (u, "(A)") allocate (state_orig) call state_orig%init () call flv%init ([11, -11, 1, -1]) call col(3)%init ([1]) call col(4)%init ([-1]) do h1 = -1, 1, 2 do h2 = -1, 1, 2 do h3 = -1, 1, 2 do h4 = -1, 1, 2 n_states = n_states + 1 call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4]) call qn%init (flv, col, hel) call state_orig%add_state (qn) end do end do end do end do call state_orig%freeze () write (u, "(A)") "* Original state: " write (u, "(A)") call state_orig%write (u) write (u, "(A)") write (u, "(A)") "* Setup quantum mask: " call qn_mask%init ([.false., .false., .false., .false.], & [.true., .true., .true., .true.], & [.false., .false., .true., .true.]) call quantum_numbers_mask_write (qn_mask, u) write (u, "(A)") write (u, "(A)") "* Reducing the state matrix using above mask and keeping the old indices:" write (u, "(A)") allocate (state_reduced) call state_orig%reduce (qn_mask, state_reduced, keep_me_index = .true.) write (u, "(A)") "* Reduced state matrix with kept indices: " call state_reduced%write (u) write (u, "(A)") write (u, "(A)") "* Reordering reduced state matrix:" write (u, "(A)") allocate (state_ordered) call state_reduced%reorder_me (state_ordered) write (u, "(A)") "* Reduced and ordered state matrix:" call state_ordered%write (u) write (u, "(A)") "* Test output end: state_matrix_6" end subroutine state_matrix_7 @ %def state_matrix_7 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Interactions} This module defines the [[interaction_t]] type. It is an extension of the [[state_matrix_t]] type. The state matrix is a representation of a multi-particle density matrix. It implements all possible flavor, color, and quantum-number assignments of the entries in a generic density matrix, and it can hold a complex matrix element for each entry. (Note that this matrix can hold non-diagonal entries in color and helicity space.) The [[interaction_t]] object associates this with a list of momenta, such that the whole object represents a multi-particle state. The [[interaction_t]] holds information about which particles are incoming, virtual (i.e., kept for the records), or outgoing. Each particle can be associated to a source within another interaction. This allows us to automatically fill those interaction momenta which have been computed or defined elsewhere. It also contains internal parent-child relations and flags for (virtual) particles which are to be treated as resonances. A quantum-number mask array summarizes, for each particle within the interaction, the treatment of flavor, color, or helicity (expose or ignore). A list of locks states which particles are bound to have an identical quantum-number mask. This is useful when the mask is changed at one place. <<[[interactions.f90]]>>= <> module interactions <> use io_units use diagnostics use sorting use lorentz use flavors use colors use helicities use quantum_numbers use state_matrices <> <> <> <> contains <> end module interactions @ %def interactions @ Given an ordered list of quantum numbers (without any subtraction index) map this list to a state matrix, such that each list index corresponds to an index of a set of quantum numbers in the state matrix, hence, the matrix element. The (unphysical) subtraction index is not a genuine quantum number and as such handled specially. <>= public :: qn_index_map_t <>= type :: qn_index_map_t private type(quantum_numbers_t), dimension(:, :), allocatable :: qn_flv type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel logical :: flip_hel = .false. integer :: n_flv = 0, n_hel = 0, n_sub = 0 integer, dimension(:, :, :), allocatable :: index integer, dimension(:,:), allocatable :: sf_index_born, sf_index_real contains <> end type qn_index_map_t @ %def qn_index_map_t @ Construct a mapping from interaction to an array of (sorted) quantum numbers. We strip all non-elementary particles (like beam) from the quantum numbers which we retrieve from the interaction. We consider helicity matrix elements only, when [[qn_hel]] is allocated. Else the helicity index is handled trivially as [[1]]. For the rescaling of the structure functions in the real subtraction and DGLAP components we need a mapping (initialized by [[qn_index_map_init_sf]]) from the real and born flavor structure indices to the structure function chain interaction matrix element with the correct initial state quantum numbers. This is stored in [[sf_index_born]] and [[sf_index_real]]. The array [[index]] is only needed for the initialisation of the Born and real index arrays and is therefore deallocated again. <>= generic :: init => init_trivial, & init_involved, & init_sf procedure, private :: init_trivial => qn_index_map_init_trivial procedure, private :: init_involved => qn_index_map_init_involved procedure, private :: init_sf => qn_index_map_init_sf <>= subroutine qn_index_map_init_trivial (self, int) class(qn_index_map_t), intent(out) :: self class(interaction_t), intent(in) :: int integer :: qn self%n_flv = int%get_n_matrix_elements () self%n_hel = 1 self%n_sub = 0 allocate (self%index(self%n_flv, self%n_hel, 0:self%n_sub), source = 0) do qn = 1, self%n_flv self%index(qn, 1, 0) = qn end do end subroutine qn_index_map_init_trivial subroutine qn_index_map_init_involved (self, int, qn_flv, n_sub, qn_hel) class(qn_index_map_t), intent(out) :: self type(interaction_t), intent(in) :: int type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv integer, intent(in) :: n_sub type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel type(quantum_numbers_t), dimension(:), allocatable :: qn, qn_int integer :: i, i_flv, i_hel, i_sub self%qn_flv = qn_flv self%n_flv = size (qn_flv, dim=2) self%n_sub = n_sub if (present (qn_hel)) then if (size (qn_flv, dim=1) /= size (qn_hel, dim=1)) then call msg_bug ("[qn_index_map_init] number of particles does not match.") end if self%qn_hel = qn_hel self%n_hel = size (qn_hel, dim=2) else self%n_hel = 1 end if allocate (self%index (self%n_flv, self%n_hel, 0:self%n_sub), source=0) associate (n_me => int%get_n_matrix_elements ()) do i = 1, n_me qn_int = int%get_quantum_numbers (i, by_me_index = .true.) qn = pack (qn_int, qn_int%are_hard_process ()) i_flv = find_flv_index (self, qn) i_hel = 1; if (allocated (self%qn_hel)) & i_hel = find_hel_index (self, qn) i_sub = find_sub_index (self, qn) self%index(i_flv, i_hel, i_sub) = i end do end associate contains integer function find_flv_index (self, qn) result (i_flv) type(qn_index_map_t), intent(in) :: self type(quantum_numbers_t), dimension(:), intent(in) :: qn integer :: j i_flv = 0 do j = 1, self%n_flv if (.not. all (qn .fmatch. self%qn_flv(:, j))) cycle i_flv = j exit end do if (i_flv < 1) then call msg_message ("QN:") call quantum_numbers_write (qn) call msg_message ("") call msg_message ("QN_FLV:") do j = 1, self%n_flv call quantum_numbers_write (self%qn_flv(:, j)) call msg_message ("") end do call msg_bug ("[find_flv_index] could not find flv in qn_flv.") end if end function find_flv_index integer function find_hel_index (self, qn) result (i_hel) type(qn_index_map_t), intent(in) :: self type(quantum_numbers_t), dimension(:), intent(in) :: qn integer :: j i_hel = 0 do j = 1, self%n_hel if (.not. all (qn .hmatch. self%qn_hel(:, j))) cycle i_hel = j exit end do if (i_hel < 1) then call msg_message ("QN:") call quantum_numbers_write (qn) call msg_message ("") call msg_message ("QN_HEL:") do j = 1, self%n_hel call quantum_numbers_write (self%qn_hel(:, j)) call msg_message ("") end do call msg_bug ("[find_hel_index] could not find hel in qn_hel.") end if end function find_hel_index integer function find_sub_index (self, qn) result (i_sub) type(qn_index_map_t), intent(in) :: self type(quantum_numbers_t), dimension(:), intent(in) :: qn integer :: s i_sub = -1 do s = 0, self%n_sub if ((all (pack(qn%get_sub (), qn%get_sub () > 0) == s)) & .or. (all (qn%get_sub () == 0) .and. s == 0)) then i_sub = s exit end if end do if (i_sub < 0) then call msg_message ("QN:") call quantum_numbers_write (qn) call msg_bug ("[find_sub_index] could not find sub in qn.") end if end function find_sub_index end subroutine qn_index_map_init_involved subroutine qn_index_map_init_sf (self, int, qn_flv, n_flv_born, n_flv_real) class(qn_index_map_t), intent(out) :: self type(interaction_t), intent(in) :: int integer, intent(in) :: n_flv_born, n_flv_real type(quantum_numbers_t), dimension(:,:), intent(in) :: qn_flv type(quantum_numbers_t), dimension(:,:), allocatable :: qn_int type(quantum_numbers_t), dimension(:), allocatable :: qn_int_tmp integer :: i, i_sub, n_flv, n_hard n_flv = int%get_n_matrix_elements () qn_int_tmp = int%get_quantum_numbers (1, by_me_index = .true.) n_hard = count (qn_int_tmp%are_hard_process ()) allocate (qn_int(n_hard, n_flv)) do i = 1, n_flv qn_int_tmp = int%get_quantum_numbers (i, by_me_index = .true.) qn_int(:, i) = pack (qn_int_tmp, qn_int_tmp%are_hard_process ()) end do call self%init (int, qn_int, int%get_n_sub ()) allocate (self%sf_index_born(n_flv_born, 0:self%n_sub)) allocate (self%sf_index_real(n_flv_real, 0:self%n_sub)) do i_sub = 0, self%n_sub do i = 1, n_flv_born self%sf_index_born(i, i_sub) = self%get_index_by_qn (qn_flv(:,i), i_sub) end do do i = 1, n_flv_real self%sf_index_real(i, i_sub) = & self%get_index_by_qn (qn_flv(:,n_flv_born + i), i_sub) end do end do deallocate (self%index) end subroutine qn_index_map_init_sf @ %def qn_index_map_init_trivial @ %def qn_index_map_init_involved @ %def qn_index_map_init_sf @ Write the index map to unit. <>= procedure :: write => qn_index_map_write <>= subroutine qn_index_map_write (self, unit) class(qn_index_map_t), intent(in) :: self integer, intent(in), optional :: unit integer :: u, i_flv, i_hel, i_sub u = given_output_unit (unit); if (u < 0) return write (u, *) "flip_hel: ", self%flip_hel do i_flv = 1, self%n_flv if (allocated (self%qn_flv)) & call quantum_numbers_write (self%qn_flv(:, i_flv)) write (u, *) do i_hel = 1, self%n_hel if (allocated (self%qn_hel)) then call quantum_numbers_write (self%qn_hel(:, i_hel)) write (u, *) end if do i_sub = 0, self%n_sub write (u, *) & "(", i_flv, ",", i_hel, ",", i_sub, ") => ", self%index(i_flv, i_hel, i_sub) end do end do end do end subroutine qn_index_map_write @ %def qn_index_map_write @ Set helicity convention. If [[flip]], then we flip the helicities of anti-particles and we remap the indices accordingly. <>= procedure :: set_helicity_flip => qn_index_map_set_helicity_flip <>= subroutine qn_index_map_set_helicity_flip (self, yorn) class(qn_index_map_t), intent(inout) :: self logical, intent(in) :: yorn integer :: i, i_flv, i_hel, i_hel_new type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel_flip integer, dimension(:, :, :), allocatable :: index if (.not. allocated (self%qn_hel)) then call msg_bug ("[qn_index_map_set_helicity_flip] & &cannot flip not-given helicity.") end if allocate (index (self%n_flv, self%n_hel, 0:self%n_sub), & source=self%index) self%flip_hel = yorn if (self%flip_hel) then do i_flv = 1, self%n_flv qn_hel_flip = self%qn_hel do i_hel = 1, self%n_hel do i = 1, size (self%qn_flv, dim=1) if (is_anti_particle (self%qn_flv(i, i_flv))) then call qn_hel_flip(i, i_hel)%flip_helicity () end if end do end do do i_hel = 1, self%n_hel i_hel_new = find_hel_index (qn_hel_flip, self%qn_hel(:, i_hel)) self%index(i_flv, i_hel_new, :) = index(i_flv, i_hel, :) end do end do end if contains logical function is_anti_particle (qn) result (yorn) type(quantum_numbers_t), intent(in) :: qn type(flavor_t) :: flv flv = qn%get_flavor () yorn = flv%get_pdg () < 0 end function is_anti_particle integer function find_hel_index (qn_sort, qn) result (i_hel) type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_sort type(quantum_numbers_t), dimension(:), intent(in) :: qn integer :: j do j = 1, size(qn_sort, dim=2) if (.not. all (qn .hmatch. qn_sort(:, j))) cycle i_hel = j exit end do end function find_hel_index end subroutine qn_index_map_set_helicity_flip @ %def qn_index_map_set_helicity_flip @ Map from the previously given quantum number and subtraction index (latter ranging from 0 to [[n_sub]]) to the (interaction) matrix element. <>= procedure :: get_index => qn_index_map_get_index <>= integer function qn_index_map_get_index (self, i_flv, i_hel, i_sub) result (index) class(qn_index_map_t), intent(in) :: self integer, intent(in) :: i_flv integer, intent(in), optional :: i_hel integer, intent(in), optional :: i_sub integer :: i_sub_opt, i_hel_opt i_sub_opt = 0; if (present (i_sub)) & i_sub_opt = i_sub i_hel_opt = 1; if (present (i_hel)) & i_hel_opt = i_hel index = 0 if (.not. allocated (self%index)) then call msg_bug ("[qn_index_map_get_index] The index map is not allocated.") end if index = self%index(i_flv, i_hel_opt, i_sub_opt) if (index <= 0) then call self%write () call msg_bug ("[qn_index_map_get_index] The index for the given quantum numbers could not be retrieved.") end if end function qn_index_map_get_index @ %def qn_index_map_get_i_flv @ Get [[n_flv]]. <>= procedure :: get_n_flv => qn_index_map_get_n_flv <>= integer function qn_index_map_get_n_flv (self) result (n_flv) class(qn_index_map_t), intent(in) :: self n_flv = self%n_flv end function qn_index_map_get_n_flv @ %def qn_index_map_get_n_flv @ Get [[n_hel]]. <>= procedure :: get_n_hel => qn_index_map_get_n_hel <>= integer function qn_index_map_get_n_hel (self) result (n_hel) class(qn_index_map_t), intent(in) :: self n_hel = self%n_hel end function qn_index_map_get_n_hel @ %def qn_index_map_get_n_flv @ Get [[n_sub]]. <>= procedure :: get_n_sub => qn_index_map_get_n_sub <>= integer function qn_index_map_get_n_sub (self) result (n_sub) class(qn_index_map_t), intent(in) :: self n_sub = self%n_sub end function qn_index_map_get_n_sub @ %def qn_index_map_get_n_sub @ Gets the index for the matrix element corresponding to a set of quantum numbers. So far, it ignores helicity (and color) indices. <>= procedure :: get_index_by_qn => qn_index_map_get_index_by_qn <>= integer function qn_index_map_get_index_by_qn (self, qn, i_sub) result (index) class(qn_index_map_t), intent(in) :: self type(quantum_numbers_t), dimension(:), intent(in) :: qn integer, intent(in), optional :: i_sub integer :: i_qn if (size (qn) /= size (self%qn_flv, dim = 1)) & call msg_bug ("[qn_index_map_get_index_by_qn] number of particles does not match.") do i_qn = 1, self%n_flv if (all (qn .fmatch. self%qn_flv(:, i_qn))) then index = self%get_index (i_qn, i_sub = i_sub) return end if end do call self%write () call msg_bug ("[qn_index_map_get_index_by_qn] The index for the given quantum & & numbers could not be retrieved.") end function qn_index_map_get_index_by_qn @ %def qn_index_map_get_index_by_qn @ <>= procedure :: get_sf_index_born => qn_index_map_get_sf_index_born <>= integer function qn_index_map_get_sf_index_born (self, i_born, i_sub) result (index) class(qn_index_map_t), intent(in) :: self integer, intent(in) :: i_born, i_sub index = self%sf_index_born(i_born, i_sub) end function qn_index_map_get_sf_index_born @ %def qn_index_map_get_sf_index_born @ <>= procedure :: get_sf_index_real => qn_index_map_get_sf_index_real <>= integer function qn_index_map_get_sf_index_real (self, i_real, i_sub) result (index) class(qn_index_map_t), intent(in) :: self integer, intent(in) :: i_real, i_sub index = self%sf_index_real(i_real, i_sub) end function qn_index_map_get_sf_index_real @ %def qn_index_map_get_sf_index_real @ \subsection{External interaction links} Each particle in an interaction can have a link to a corresponding particle in another interaction. This allows to fetch the momenta of incoming or virtual particles from the interaction where they are defined. The link object consists of a pointer to the interaction and an index. <>= type :: external_link_t private type(interaction_t), pointer :: int => null () integer :: i end type external_link_t @ %def external_link_t @ Set an external link. <>= subroutine external_link_set (link, int, i) type(external_link_t), intent(out) :: link type(interaction_t), target, intent(in) :: int integer, intent(in) :: i if (i /= 0) then link%int => int link%i = i end if end subroutine external_link_set @ %def external_link_set @ Reassign an external link to a new interaction (which should be an image of the original target). <>= subroutine external_link_reassign (link, int_src, int_target) type(external_link_t), intent(inout) :: link type(interaction_t), intent(in) :: int_src type(interaction_t), intent(in), target :: int_target if (associated (link%int)) then if (link%int%tag == int_src%tag) link%int => int_target end if end subroutine external_link_reassign @ %def external_link_reassign @ Return true if the link is set <>= function external_link_is_set (link) result (flag) logical :: flag type(external_link_t), intent(in) :: link flag = associated (link%int) end function external_link_is_set @ %def external_link_is_set @ Return the interaction pointer. <>= public :: external_link_get_ptr <>= function external_link_get_ptr (link) result (int) type(interaction_t), pointer :: int type(external_link_t), intent(in) :: link int => link%int end function external_link_get_ptr @ %def external_link_get_ptr @ Return the index within that interaction <>= public :: external_link_get_index <>= function external_link_get_index (link) result (i) integer :: i type(external_link_t), intent(in) :: link i = link%i end function external_link_get_index @ %def external_link_get_index @ Return a pointer to the momentum of the corresponding particle. If there is no association, return a null pointer. <>= function external_link_get_momentum_ptr (link) result (p) type(vector4_t), pointer :: p type(external_link_t), intent(in) :: link if (associated (link%int)) then p => link%int%p(link%i) else p => null () end if end function external_link_get_momentum_ptr @ %def external_link_get_momentum_ptr @ \subsection{Internal relations} In addition to the external links, particles within the interaction have parent-child relations. Here, more than one link is possible, and we set up an array. <>= type :: internal_link_list_t private integer :: length = 0 integer, dimension(:), allocatable :: link contains <> end type internal_link_list_t @ %def internal_link_t internal_link_list_t @ Output, non-advancing. <>= procedure :: write => internal_link_list_write <>= subroutine internal_link_list_write (object, unit) class(internal_link_list_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) do i = 1, object%length write (u, "(1x,I0)", advance="no") object%link(i) end do end subroutine internal_link_list_write @ %def internal_link_list_write @ Append an item. Start with an array size of 2 and double the size if necessary. Make sure that the indices are stored in ascending order. To this end, shift the existing entries right, starting from the end, as long as they are larger than the new entry. <>= procedure :: append => internal_link_list_append <>= subroutine internal_link_list_append (link_list, link) class(internal_link_list_t), intent(inout) :: link_list integer, intent(in) :: link integer :: l, j integer, dimension(:), allocatable :: tmp l = link_list%length if (allocated (link_list%link)) then if (l == size (link_list%link)) then allocate (tmp (2 * l)) tmp(:l) = link_list%link call move_alloc (from = tmp, to = link_list%link) end if else allocate (link_list%link (2)) end if link_list%link(l+1) = link SHIFT_LINK_IN_PLACE: do j = l, 1, -1 if (link >= link_list%link(j)) then exit SHIFT_LINK_IN_PLACE else link_list%link(j+1) = link_list%link(j) link_list%link(j) = link end if end do SHIFT_LINK_IN_PLACE link_list%length = l + 1 end subroutine internal_link_list_append @ %def internal_link_list_append @ Return true if the link list is nonempty: <>= procedure :: has_entries => internal_link_list_has_entries <>= function internal_link_list_has_entries (link_list) result (flag) class(internal_link_list_t), intent(in) :: link_list logical :: flag flag = link_list%length > 0 end function internal_link_list_has_entries @ %def internal_link_list_has_entries @ Return the list length <>= procedure :: get_length => internal_link_list_get_length <>= function internal_link_list_get_length (link_list) result (length) class(internal_link_list_t), intent(in) :: link_list integer :: length length = link_list%length end function internal_link_list_get_length @ %def internal_link_list_get_length @ Return an entry. <>= procedure :: get_link => internal_link_list_get_link <>= function internal_link_list_get_link (link_list, i) result (link) class(internal_link_list_t), intent(in) :: link_list integer, intent(in) :: i integer :: link if (i <= link_list%length) then link = link_list%link(i) else call msg_bug ("Internal link list: out of bounds") end if end function internal_link_list_get_link @ %def internal_link_list_get_link @ \subsection{The interaction type} An interaction is an entangled system of particles. Thus, the interaction object consists of two parts: the subevent, and the quantum state which technically is a trie. The subnode levels beyond the trie root node are in correspondence to the subevent, so both should be traversed in parallel. The subevent is implemented as an allocatable array of four-momenta. The first [[n_in]] particles are incoming, [[n_vir]] particles in-between can be kept for bookkeeping, and the last [[n_out]] particles are outgoing. Distinct interactions are linked by their particles: for each particle, we have the possibility of links to corresponding particles in other interactions. Furthermore, for bookkeeping purposes we have a self-link array [[relations]] where the parent-child relations are kept, and a flag array [[resonant]] which is set for an intermediate resonance. Each momentum is associated with masks for flavor, color, and helicity. If a mask entry is set, the associated quantum number is to be ignored for that particle. If any mask has changed, the flag [[update]] is set. We can have particle pairs locked together. If this is the case, the corresponding mask entries are bound to be equal. This is useful for particles that go through the interaction. The interaction tag serves bookkeeping purposes. In particular, it identifies links in printout. <>= public :: interaction_t <>= type :: interaction_t private integer :: tag = 0 type(state_matrix_t) :: state_matrix integer :: n_in = 0 integer :: n_vir = 0 integer :: n_out = 0 integer :: n_tot = 0 logical, dimension(:), allocatable :: p_is_known type(vector4_t), dimension(:), allocatable :: p type(external_link_t), dimension(:), allocatable :: source type(internal_link_list_t), dimension(:), allocatable :: parents type(internal_link_list_t), dimension(:), allocatable :: children logical, dimension(:), allocatable :: resonant type(quantum_numbers_mask_t), dimension(:), allocatable :: mask integer, dimension(:), allocatable :: hel_lock logical :: update_state_matrix = .false. logical :: update_values = .false. type(qn_index_map_t) :: qn_index contains <> end type interaction_t @ %def interaction_particle_p interaction_t @ Initialize the particle array with a fixed size. The first [[n_in]] particles are incoming, the rest outgoing. Masks are optional. There is also an optional tag. The interaction still needs fixing the values, but that is to be done after all branches have been added. Interaction tags are assigned consecutively, using a [[save]]d variable local to this procedure. If desired, we can provide a seed for the interaction tags. Such a seed should be positive. The default seed is one. [[tag=0]] indicates an empty interaction. If [[set_relations]] is set and true, we establish parent-child relations for all incoming and outgoing particles. Virtual particles are skipped; this option is normally used only for interations without virtual particles. <>= procedure :: basic_init => interaction_init <>= subroutine interaction_init & (int, n_in, n_vir, n_out, & tag, resonant, mask, hel_lock, set_relations, store_values) class(interaction_t), intent(out) :: int integer, intent(in) :: n_in, n_vir, n_out integer, intent(in), optional :: tag logical, dimension(:), intent(in), optional :: resonant type(quantum_numbers_mask_t), dimension(:), intent(in), optional :: mask integer, dimension(:), intent(in), optional :: hel_lock logical, intent(in), optional :: set_relations, store_values logical :: set_rel integer :: i, j set_rel = .false.; if (present (set_relations)) set_rel = set_relations call interaction_set_tag (int, tag) call int%state_matrix%init (store_values) int%n_in = n_in int%n_vir = n_vir int%n_out = n_out int%n_tot = n_in + n_vir + n_out allocate (int%p_is_known (int%n_tot)) int%p_is_known = .false. allocate (int%p (int%n_tot)) allocate (int%source (int%n_tot)) allocate (int%parents (int%n_tot)) allocate (int%children (int%n_tot)) allocate (int%resonant (int%n_tot)) if (present (resonant)) then int%resonant = resonant else int%resonant = .false. end if allocate (int%mask (int%n_tot)) allocate (int%hel_lock (int%n_tot)) if (present (mask)) then int%mask = mask end if if (present (hel_lock)) then int%hel_lock = hel_lock else int%hel_lock = 0 end if int%update_state_matrix = .false. int%update_values = .true. if (set_rel) then do i = 1, n_in do j = 1, n_out call int%relate (i, n_in + j) end do end do end if end subroutine interaction_init @ %def interaction_init @ <>= generic :: init_qn_index => init_qn_index_trivial, & init_qn_index_involved, & init_qn_index_sf procedure :: init_qn_index_trivial => interaction_init_qn_index_trivial procedure :: init_qn_index_involved => interaction_init_qn_index_involved procedure :: init_qn_index_sf => interaction_init_qn_index_sf <>= subroutine interaction_init_qn_index_trivial (int) class(interaction_t), intent(inout) :: int call int%qn_index%init (int) end subroutine interaction_init_qn_index_trivial subroutine interaction_init_qn_index_involved (int, qn_flv, n_sub, qn_hel) class(interaction_t), intent(inout) :: int type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv integer, intent(in) :: n_sub type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel call int%qn_index%init (int, qn_flv, n_sub, qn_hel) end subroutine interaction_init_qn_index_involved subroutine interaction_init_qn_index_sf (int, qn_flv, n_flv_born, n_flv_real) class(interaction_t), intent(inout) :: int integer, intent(in) :: n_flv_born, n_flv_real type(quantum_numbers_t), dimension(:,:), intent(in) :: qn_flv call int%qn_index%init (int, qn_flv, n_flv_born, n_flv_real) end subroutine interaction_init_qn_index_sf @ %def interaction_init_qn_index_trivial @ %def interaction_init_qn_index @ %def interaction_init_qn_index_sf @ <>= procedure :: set_qn_index_helicity_flip => interaction_set_qn_index_helicity_flip <>= subroutine interaction_set_qn_index_helicity_flip (int, yorn) class(interaction_t), intent(inout) :: int logical, intent(in) :: yorn call int%qn_index%set_helicity_flip (yorn) end subroutine interaction_set_qn_index_helicity_flip @ %def interaction_get_qn_index_n_flv @ <>= procedure :: get_qn_index => interaction_get_qn_index procedure :: get_sf_qn_index_born => interaction_get_sf_qn_index_born procedure :: get_sf_qn_index_real => interaction_get_sf_qn_index_real <>= integer function interaction_get_qn_index (int, i_flv, i_hel, i_sub) result (index) class(interaction_t), intent(in) :: int integer, intent(in) :: i_flv integer, intent(in), optional :: i_hel integer, intent(in), optional :: i_sub index = int%qn_index%get_index (i_flv, i_hel, i_sub) end function interaction_get_qn_index integer function interaction_get_sf_qn_index_born (int, i_born, i_sub) result (index) class(interaction_t), intent(in) :: int integer, intent(in) :: i_born, i_sub index = int%qn_index%get_sf_index_born (i_born, i_sub) end function interaction_get_sf_qn_index_born integer function interaction_get_sf_qn_index_real (int, i_real, i_sub) result (index) class(interaction_t), intent(in) :: int integer, intent(in) :: i_real, i_sub index = int%qn_index%get_sf_index_real (i_real, i_sub) end function interaction_get_sf_qn_index_real @ %def interaction_get_qn_index @ %def interaction_get_sf_qn_index_born @ %def interaction_get_sf_qn_index_real @ <>= procedure :: get_qn_index_n_flv => interaction_get_qn_index_n_flv procedure :: get_qn_index_n_hel => interaction_get_qn_index_n_hel procedure :: get_qn_index_n_sub => interaction_get_qn_index_n_sub <>= integer function interaction_get_qn_index_n_flv (int) result (index) class(interaction_t), intent(in) :: int index = int%qn_index%get_n_flv () end function interaction_get_qn_index_n_flv integer function interaction_get_qn_index_n_hel (int) result (index) class(interaction_t), intent(in) :: int index = int%qn_index%get_n_hel () end function interaction_get_qn_index_n_hel integer function interaction_get_qn_index_n_sub (int) result (index) class(interaction_t), intent(in) :: int index = int%qn_index%get_n_sub () end function interaction_get_qn_index_n_sub @ %def interaction_get_qn_index_n_flv @ %def interaction_get_qn_index_n_hel @ %def interaction_get_qn_index_n_sub @ Set or create a unique tag for the interaction. Without interaction, reset the tag counter. <>= subroutine interaction_set_tag (int, tag) type(interaction_t), intent(inout), optional :: int integer, intent(in), optional :: tag integer, save :: stored_tag = 1 if (present (int)) then if (present (tag)) then int%tag = tag else int%tag = stored_tag stored_tag = stored_tag + 1 end if else if (present (tag)) then stored_tag = tag else stored_tag = 1 end if end subroutine interaction_set_tag @ %def interaction_set_tag @ The public interface for the previous procedure only covers the reset functionality. <>= public :: reset_interaction_counter <>= subroutine reset_interaction_counter (tag) integer, intent(in), optional :: tag call interaction_set_tag (tag=tag) end subroutine reset_interaction_counter @ %def reset_interaction_counter @ Finalizer: The state-matrix object contains pointers. <>= procedure :: final => interaction_final <>= subroutine interaction_final (object) class(interaction_t), intent(inout) :: object call object%state_matrix%final () end subroutine interaction_final @ %def interaction_final @ Output. The [[verbose]] option refers to the state matrix output. <>= procedure :: basic_write => interaction_write <>= subroutine interaction_write & (int, unit, verbose, show_momentum_sum, show_mass, show_state, & col_verbose, testflag) class(interaction_t), intent(in) :: int integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, show_momentum_sum, show_mass logical, intent(in), optional :: show_state, col_verbose, testflag integer :: u integer :: i, index_link type(interaction_t), pointer :: int_link logical :: show_st u = given_output_unit (unit); if (u < 0) return show_st = .true.; if (present (show_state)) show_st = show_state if (int%tag /= 0) then write (u, "(1x,A,I0)") "Interaction: ", int%tag do i = 1, int%n_tot if (i == 1 .and. int%n_in > 0) then write (u, "(1x,A)") "Incoming:" else if (i == int%n_in + 1 .and. int%n_vir > 0) then write (u, "(1x,A)") "Virtual:" else if (i == int%n_in + int%n_vir + 1 .and. int%n_out > 0) then write (u, "(1x,A)") "Outgoing:" end if write (u, "(1x,A,1x,I0)", advance="no") "Particle", i if (allocated (int%resonant)) then if (int%resonant(i)) then write (u, "(A)") "[r]" else write (u, *) end if else write (u, *) end if if (allocated (int%p)) then if (int%p_is_known(i)) then call vector4_write (int%p(i), u, show_mass, testflag) else write (u, "(A)") " [momentum undefined]" end if else write (u, "(A)") " [momentum not allocated]" end if if (allocated (int%mask)) then write (u, "(1x,A)", advance="no") "mask [fch] = " call int%mask(i)%write (u) write (u, *) end if if (int%parents(i)%has_entries () & .or. int%children(i)%has_entries ()) then write (u, "(1x,A)", advance="no") "internal links:" call int%parents(i)%write (u) if (int%parents(i)%has_entries ()) & write (u, "(1x,A)", advance="no") "=>" write (u, "(1x,A)", advance="no") "X" if (int%children(i)%has_entries ()) & write (u, "(1x,A)", advance="no") "=>" call int%children(i)%write (u) write (u, *) end if if (allocated (int%hel_lock)) then if (int%hel_lock(i) /= 0) then write (u, "(1x,A,1x,I0)") "helicity lock:", int%hel_lock(i) end if end if if (external_link_is_set (int%source(i))) then write (u, "(1x,A)", advance="no") "source:" int_link => external_link_get_ptr (int%source(i)) index_link = external_link_get_index (int%source(i)) write (u, "(1x,'(',I0,')',I0)", advance="no") & int_link%tag, index_link write (u, *) end if end do if (present (show_momentum_sum)) then if (allocated (int%p) .and. show_momentum_sum) then write (u, "(1x,A)") "Incoming particles (sum):" call vector4_write & (sum (int%p(1 : int%n_in)), u, show_mass = show_mass) write (u, "(1x,A)") "Outgoing particles (sum):" call vector4_write & (sum (int%p(int%n_in + int%n_vir + 1 : )), & u, show_mass = show_mass) write (u, *) end if end if if (show_st) then call int%write_state_matrix (write_value_list = verbose, & verbose = verbose, unit = unit, col_verbose = col_verbose, & testflag = testflag) end if else write (u, "(1x,A)") "Interaction: [empty]" end if end subroutine interaction_write @ %def interaction_write @ <>= procedure :: write_state_matrix => interaction_write_state_matrix <>= subroutine interaction_write_state_matrix (int, unit, write_value_list, & verbose, col_verbose, testflag) class(interaction_t), intent(in) :: int logical, intent(in), optional :: write_value_list, verbose, col_verbose logical, intent(in), optional :: testflag integer, intent(in), optional :: unit call int%state_matrix%write (write_value_list = verbose, & verbose = verbose, unit = unit, col_verbose = col_verbose, & testflag = testflag) end subroutine interaction_write_state_matrix @ %def interaction_write_state_matrix @ Reduce the [[state_matrix]] over the quantum mask. During the reduce procedure the iterator does not conserve the order of the matrix element respective their quantum numbers. Setting the [[keep_order]] results in a reorder state matrix with reintroduced matrix element indices. <>= procedure :: reduce_state_matrix => interaction_reduce_state_matrix <>= subroutine interaction_reduce_state_matrix (int, qn_mask, keep_order) class(interaction_t), intent(inout) :: int type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask logical, optional, intent(in) :: keep_order type(state_matrix_t) :: state logical :: opt_keep_order opt_keep_order = .false. if (present (keep_order)) opt_keep_order = keep_order call int%state_matrix%reduce (qn_mask, state, keep_me_index = keep_order) int%state_matrix = state if (opt_keep_order) then call int%state_matrix%reorder_me (state) int%state_matrix = state end if end subroutine interaction_reduce_state_matrix @ %def interaction_reduce_state_matrix @ Assignment: We implement this as a deep copy. This applies, in particular, to the state-matrix and internal-link components. Furthermore, the new interaction acquires a new tag. <>= public :: assignment(=) <>= interface assignment(=) module procedure interaction_assign end interface <>= subroutine interaction_assign (int_out, int_in) type(interaction_t), intent(out) :: int_out type(interaction_t), intent(in), target :: int_in call interaction_set_tag (int_out) int_out%state_matrix = int_in%state_matrix int_out%n_in = int_in%n_in int_out%n_out = int_in%n_out int_out%n_vir = int_in%n_vir int_out%n_tot = int_in%n_tot if (allocated (int_in%p_is_known)) then allocate (int_out%p_is_known (size (int_in%p_is_known))) int_out%p_is_known = int_in%p_is_known end if if (allocated (int_in%p)) then allocate (int_out%p (size (int_in%p))) int_out%p = int_in%p end if if (allocated (int_in%source)) then allocate (int_out%source (size (int_in%source))) int_out%source = int_in%source end if if (allocated (int_in%parents)) then allocate (int_out%parents (size (int_in%parents))) int_out%parents = int_in%parents end if if (allocated (int_in%children)) then allocate (int_out%children (size (int_in%children))) int_out%children = int_in%children end if if (allocated (int_in%resonant)) then allocate (int_out%resonant (size (int_in%resonant))) int_out%resonant = int_in%resonant end if if (allocated (int_in%mask)) then allocate (int_out%mask (size (int_in%mask))) int_out%mask = int_in%mask end if if (allocated (int_in%hel_lock)) then allocate (int_out%hel_lock (size (int_in%hel_lock))) int_out%hel_lock = int_in%hel_lock end if int_out%update_state_matrix = int_in%update_state_matrix int_out%update_values = int_in%update_values end subroutine interaction_assign @ %def interaction_assign @ \subsection{Methods inherited from the state matrix member} Until F2003 is standard, we cannot implement inheritance directly. Therefore, we need wrappers for ``inherited'' methods. Make a new branch in the state matrix if it does not yet exist. This is not just a wrapper but it introduces the interaction mask: where a quantum number is masked, it is not transferred but set undefined. After this, the value array has to be updated. <>= procedure :: add_state => interaction_add_state <>= subroutine interaction_add_state & (int, qn, index, value, sum_values, counter_index, ignore_sub_for_qn, me_index) class(interaction_t), intent(inout) :: int type(quantum_numbers_t), dimension(:), intent(in) :: qn integer, intent(in), optional :: index complex(default), intent(in), optional :: value logical, intent(in), optional :: sum_values integer, intent(in), optional :: counter_index logical, intent(in), optional :: ignore_sub_for_qn integer, intent(out), optional :: me_index type(quantum_numbers_t), dimension(size(qn)) :: qn_tmp qn_tmp = qn call qn_tmp%undefine (int%mask) call int%state_matrix%add_state (qn_tmp, index, value, sum_values, & counter_index, ignore_sub_for_qn, me_index) int%update_values = .true. end subroutine interaction_add_state @ %def interaction_add_state @ Freeze the quantum state: First collapse the quantum state, i.e., remove quantum numbers if any mask has changed, then fix the array of value pointers. <>= procedure :: freeze => interaction_freeze <>= subroutine interaction_freeze (int) class(interaction_t), intent(inout) :: int if (int%update_state_matrix) then call int%state_matrix%collapse (int%mask) int%update_state_matrix = .false. int%update_values = .true. end if if (int%update_values) then call int%state_matrix%freeze () int%update_values = .false. end if end subroutine interaction_freeze @ %def interaction_freeze @ Return true if the state matrix is empty. <>= procedure :: is_empty => interaction_is_empty <>= pure function interaction_is_empty (int) result (flag) logical :: flag class(interaction_t), intent(in) :: int flag = int%state_matrix%is_empty () end function interaction_is_empty @ %def interaction_is_empty @ Get the number of values stored in the state matrix: <>= procedure :: get_n_matrix_elements => & interaction_get_n_matrix_elements <>= pure function interaction_get_n_matrix_elements (int) result (n) integer :: n class(interaction_t), intent(in) :: int n = int%state_matrix%get_n_matrix_elements () end function interaction_get_n_matrix_elements @ %def interaction_get_n_matrix_elements @ <>= procedure :: get_state_depth => interaction_get_state_depth <>= function interaction_get_state_depth (int) result (n) integer :: n class(interaction_t), intent(in) :: int n = int%state_matrix%get_depth () end function interaction_get_state_depth @ %def interaction_get_state_depth @ <>= procedure :: get_n_in_helicities => interaction_get_n_in_helicities <>= function interaction_get_n_in_helicities (int) result (n_hel) integer :: n_hel class(interaction_t), intent(in) :: int type(interaction_t) :: int_copy type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(quantum_numbers_t), dimension(:,:), allocatable :: qn integer :: i allocate (qn_mask (int%n_tot)) do i = 1, int%n_tot if (i <= int%n_in) then call qn_mask(i)%init (.true., .true., .false.) else call qn_mask(i)%init (.true., .true., .true.) end if end do int_copy = int call int_copy%set_mask (qn_mask) call int_copy%freeze () allocate (qn (int_copy%state_matrix%get_n_matrix_elements (), & int_copy%state_matrix%get_depth ())) qn = int_copy%get_quantum_numbers () n_hel = 0 do i = 1, size (qn, dim=1) if (all (qn(:, i)%get_subtraction_index () == 0)) n_hel = n_hel + 1 end do call int_copy%final () deallocate (qn_mask) deallocate (qn) end function interaction_get_n_in_helicities @ %def interaction_get_n_in_helicities @ Get the size of the [[me]]-array of the associated state matrix for debugging purposes <>= procedure :: get_me_size => interaction_get_me_size <>= pure function interaction_get_me_size (int) result (n) integer :: n class(interaction_t), intent(in) :: int n = int%state_matrix%get_me_size () end function interaction_get_me_size @ %def interaction_get_me_size @ Get the norm of the state matrix (if the norm has been taken out, otherwise this would be unity). <>= procedure :: get_norm => interaction_get_norm <>= pure function interaction_get_norm (int) result (norm) real(default) :: norm class(interaction_t), intent(in) :: int norm = int%state_matrix%get_norm () end function interaction_get_norm @ %def interaction_get_norm @ <>= procedure :: get_n_sub => interaction_get_n_sub <>= function interaction_get_n_sub (int) result (n_sub) integer :: n_sub class(interaction_t), intent(in) :: int n_sub = int%state_matrix%get_n_sub () end function interaction_get_n_sub @ %def interaction_get_n_sub @ Get the quantum number array that corresponds to a given index. <>= generic :: get_quantum_numbers => get_quantum_numbers_single, & get_quantum_numbers_all, & get_quantum_numbers_all_qn_mask procedure :: get_quantum_numbers_single => & interaction_get_quantum_numbers_single procedure :: get_quantum_numbers_all => & interaction_get_quantum_numbers_all procedure :: get_quantum_numbers_all_qn_mask => & interaction_get_quantum_numbers_all_qn_mask <>= function interaction_get_quantum_numbers_single (int, i, by_me_index) result (qn) type(quantum_numbers_t), dimension(:), allocatable :: qn class(interaction_t), intent(in), target :: int integer, intent(in) :: i logical, intent(in), optional :: by_me_index allocate (qn (int%state_matrix%get_depth ())) qn = int%state_matrix%get_quantum_number (i, by_me_index) end function interaction_get_quantum_numbers_single function interaction_get_quantum_numbers_all (int) result (qn) type(quantum_numbers_t), dimension(:,:), allocatable :: qn class(interaction_t), intent(in), target :: int integer :: i <> <>= allocate (qn (int%state_matrix%get_depth(), & int%state_matrix%get_n_matrix_elements ())) do i = 1, int%state_matrix%get_n_matrix_elements () qn (:, i) = int%state_matrix%get_quantum_number (i) end do <>= end function interaction_get_quantum_numbers_all function interaction_get_quantum_numbers_all_qn_mask (int, qn_mask) & result (qn) type(quantum_numbers_t), dimension(:,:), allocatable :: qn class(interaction_t), intent(in) :: int type(quantum_numbers_mask_t), intent(in) :: qn_mask integer :: n_redundant, n_all, n_me integer :: i type(quantum_numbers_t), dimension(:,:), allocatable :: qn_all <> <>= call int%state_matrix%get_quantum_numbers (qn_all) n_redundant = count (qn_all%are_redundant (qn_mask)) n_all = size (qn_all) !!! Number of matrix elements = survivors / n_particles n_me = (n_all - n_redundant) / int%state_matrix%get_depth () allocate (qn (int%state_matrix%get_depth(), n_me)) do i = 1, n_me if (.not. any (qn_all(i, :)%are_redundant (qn_mask))) & qn (:, i) = qn_all (i, :) end do <>= end function interaction_get_quantum_numbers_all_qn_mask @ %def interaction_get_quantum_numbers_single @ %def interaction_get_quantum_numbers_all @ %def interaction_get_quantum_numbers_all_qn_mask @ @ <>= procedure :: get_quantum_numbers_all_sub => interaction_get_quantum_numbers_all_sub <>= subroutine interaction_get_quantum_numbers_all_sub (int, qn) class(interaction_t), intent(in) :: int type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn integer :: i <> end subroutine interaction_get_quantum_numbers_all_sub @ %def interaction_get_quantum_numbers_all @ <>= procedure :: get_flavors => interaction_get_flavors <>= subroutine interaction_get_flavors (int, only_elementary, qn_mask, flv) class(interaction_t), intent(in), target :: int logical, intent(in) :: only_elementary type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask integer, intent(out), dimension(:,:), allocatable :: flv call int%state_matrix%get_flavors (only_elementary, qn_mask, flv) end subroutine interaction_get_flavors @ %def interaction_get_flavors @ <>= procedure :: get_quantum_numbers_mask => interaction_get_quantum_numbers_mask <>= subroutine interaction_get_quantum_numbers_mask (int, qn_mask, qn) class(interaction_t), intent(in) :: int type(quantum_numbers_mask_t), intent(in) :: qn_mask type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn integer :: n_redundant, n_all, n_me integer :: i type(quantum_numbers_t), dimension(:,:), allocatable :: qn_all <> end subroutine interaction_get_quantum_numbers_mask @ %def interaction_get_quantum_numbers_mask @ Get the matrix element that corresponds to a set of quantum numbers, a given index, or return the whole array. <>= generic :: get_matrix_element => get_matrix_element_single generic :: get_matrix_element => get_matrix_element_array procedure :: get_matrix_element_single => & interaction_get_matrix_element_single procedure :: get_matrix_element_array => & interaction_get_matrix_element_array <>= elemental function interaction_get_matrix_element_single (int, i) result (me) complex(default) :: me class(interaction_t), intent(in) :: int integer, intent(in) :: i me = int%state_matrix%get_matrix_element (i) end function interaction_get_matrix_element_single @ %def interaction_get_matrix_element_single <>= function interaction_get_matrix_element_array (int) result (me) complex(default), dimension(:), allocatable :: me class(interaction_t), intent(in) :: int allocate (me (int%get_n_matrix_elements ())) me = int%state_matrix%get_matrix_element () end function interaction_get_matrix_element_array @ %def interaction_get_matrix_element_array @ Set the complex value(s) stored in the quantum state. <>= generic :: set_matrix_element => interaction_set_matrix_element_qn, & interaction_set_matrix_element_all, & interaction_set_matrix_element_array, & interaction_set_matrix_element_single, & interaction_set_matrix_element_clone procedure :: interaction_set_matrix_element_qn procedure :: interaction_set_matrix_element_all procedure :: interaction_set_matrix_element_array procedure :: interaction_set_matrix_element_single procedure :: interaction_set_matrix_element_clone @ %def interaction_set_matrix_element @ Indirect access via the quantum number array: <>= subroutine interaction_set_matrix_element_qn (int, qn, val) class(interaction_t), intent(inout) :: int type(quantum_numbers_t), dimension(:), intent(in) :: qn complex(default), intent(in) :: val call int%state_matrix%set_matrix_element (qn, val) end subroutine interaction_set_matrix_element_qn @ %def interaction_set_matrix_element @ Set all entries of the matrix-element array to a given value. <>= subroutine interaction_set_matrix_element_all (int, value) class(interaction_t), intent(inout) :: int complex(default), intent(in) :: value call int%state_matrix%set_matrix_element (value) end subroutine interaction_set_matrix_element_all @ %def interaction_set_matrix_element_all @ Set the matrix-element array directly. <>= subroutine interaction_set_matrix_element_array (int, value, range) class(interaction_t), intent(inout) :: int complex(default), intent(in), dimension(:) :: value integer, intent(in), dimension(:), optional :: range call int%state_matrix%set_matrix_element (value, range) end subroutine interaction_set_matrix_element_array pure subroutine interaction_set_matrix_element_single (int, i, value) class(interaction_t), intent(inout) :: int integer, intent(in) :: i complex(default), intent(in) :: value call int%state_matrix%set_matrix_element (i, value) end subroutine interaction_set_matrix_element_single @ %def interaction_set_matrix_element_array @ %def interaction_set_matrix_element_single @ Clone from another (matching) interaction. <>= subroutine interaction_set_matrix_element_clone (int, int1) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in) :: int1 call int%state_matrix%set_matrix_element (int1%state_matrix) end subroutine interaction_set_matrix_element_clone @ %def interaction_set_matrix_element_clone @ <>= procedure :: set_only_matrix_element => interaction_set_only_matrix_element <>= subroutine interaction_set_only_matrix_element (int, i, value) class(interaction_t), intent(inout) :: int integer, intent(in) :: i complex(default), intent(in) :: value call int%set_matrix_element (cmplx (0, 0, default)) call int%set_matrix_element (i, value) end subroutine interaction_set_only_matrix_element @ %def interaction_set_only_matrix_element @ <>= procedure :: add_to_matrix_element => interaction_add_to_matrix_element <>= subroutine interaction_add_to_matrix_element (int, qn, value, match_only_flavor) class(interaction_t), intent(inout) :: int type(quantum_numbers_t), dimension(:), intent(in) :: qn complex(default), intent(in) :: value logical, intent(in), optional :: match_only_flavor call int%state_matrix%add_to_matrix_element (qn, value, match_only_flavor) end subroutine interaction_add_to_matrix_element @ %def interaction_add_to_matrix_element @ Get the indices of any diagonal matrix elements. <>= procedure :: get_diagonal_entries => interaction_get_diagonal_entries <>= subroutine interaction_get_diagonal_entries (int, i) class(interaction_t), intent(in) :: int integer, dimension(:), allocatable, intent(out) :: i call int%state_matrix%get_diagonal_entries (i) end subroutine interaction_get_diagonal_entries @ %def interaction_get_diagonal_entries @ Renormalize the state matrix by its trace, if nonzero. The renormalization is reflected in the state-matrix norm. <>= procedure :: normalize_by_trace => interaction_normalize_by_trace <>= subroutine interaction_normalize_by_trace (int) class(interaction_t), intent(inout) :: int call int%state_matrix%normalize_by_trace () end subroutine interaction_normalize_by_trace @ %def interaction_normalize_by_trace @ Analogous, but renormalize by maximal (absolute) value. <>= procedure :: normalize_by_max => interaction_normalize_by_max <>= subroutine interaction_normalize_by_max (int) class(interaction_t), intent(inout) :: int call int%state_matrix%normalize_by_max () end subroutine interaction_normalize_by_max @ %def interaction_normalize_by_max @ Explicitly set the norm value (of the state matrix). <>= procedure :: set_norm => interaction_set_norm <>= subroutine interaction_set_norm (int, norm) class(interaction_t), intent(inout) :: int real(default), intent(in) :: norm call int%state_matrix%set_norm (norm) end subroutine interaction_set_norm @ %def interaction_set_norm @ <>= procedure :: set_state_matrix => interaction_set_state_matrix <>= subroutine interaction_set_state_matrix (int, state) class(interaction_t), intent(inout) :: int type(state_matrix_t), intent(in) :: state int%state_matrix = state end subroutine interaction_set_state_matrix @ %def interaction_set_state_matrix @ Return the maximum absolute value of color indices. <>= procedure :: get_max_color_value => & interaction_get_max_color_value <>= function interaction_get_max_color_value (int) result (cmax) class(interaction_t), intent(in) :: int integer :: cmax cmax = int%state_matrix%get_max_color_value () end function interaction_get_max_color_value @ %def interaction_get_max_color_value @ Factorize the state matrix into single-particle state matrices, the branch selection depending on a (random) value between 0 and 1; optionally also return a correlated state matrix. <>= procedure :: factorize => interaction_factorize <>= subroutine interaction_factorize & (int, mode, x, ok, single_state, correlated_state, qn_in) class(interaction_t), intent(in), target :: int integer, intent(in) :: mode real(default), intent(in) :: x logical, intent(out) :: ok type(state_matrix_t), & dimension(:), allocatable, intent(out) :: single_state type(state_matrix_t), intent(out), optional :: correlated_state type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in call int%state_matrix%factorize & (mode, x, ok, single_state, correlated_state, qn_in) end subroutine interaction_factorize @ %def interaction_factorize @ Sum all matrix element values <>= procedure :: sum => interaction_sum <>= function interaction_sum (int) result (value) class(interaction_t), intent(in) :: int complex(default) :: value value = int%state_matrix%sum () end function interaction_sum @ %def interaction_sum @ Append new states which are color-contracted versions of the existing states. The matrix element index of each color contraction coincides with the index of its origin, so no new matrix elements are generated. After this operation, no [[freeze]] must be performed anymore. <>= procedure :: add_color_contractions => & interaction_add_color_contractions <>= subroutine interaction_add_color_contractions (int) class(interaction_t), intent(inout) :: int call int%state_matrix%add_color_contractions () end subroutine interaction_add_color_contractions @ %def interaction_add_color_contractions @ Multiply matrix elements from two interactions. Choose the elements as given by the integer index arrays, multiply them and store the sum of products in the indicated matrix element. The suffixes mean: c=conjugate first factor; f=include weighting factor. <>= procedure :: evaluate_product => interaction_evaluate_product procedure :: evaluate_product_cf => interaction_evaluate_product_cf procedure :: evaluate_square_c => interaction_evaluate_square_c procedure :: evaluate_sum => interaction_evaluate_sum procedure :: evaluate_me_sum => interaction_evaluate_me_sum <>= pure subroutine interaction_evaluate_product & (int, i, int1, int2, index1, index2) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1, int2 integer, dimension(:), intent(in) :: index1, index2 call int%state_matrix%evaluate_product & (i, int1%state_matrix, int2%state_matrix, & index1, index2) end subroutine interaction_evaluate_product pure subroutine interaction_evaluate_product_cf & (int, i, int1, int2, index1, index2, factor) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1, int2 integer, dimension(:), intent(in) :: index1, index2 complex(default), dimension(:), intent(in) :: factor call int%state_matrix%evaluate_product_cf & (i, int1%state_matrix, int2%state_matrix, & index1, index2, factor) end subroutine interaction_evaluate_product_cf pure subroutine interaction_evaluate_square_c (int, i, int1, index1) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1 integer, dimension(:), intent(in) :: index1 call int%state_matrix%evaluate_square_c (i, int1%state_matrix, index1) end subroutine interaction_evaluate_square_c pure subroutine interaction_evaluate_sum (int, i, int1, index1) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1 integer, dimension(:), intent(in) :: index1 call int%state_matrix%evaluate_sum (i, int1%state_matrix, index1) end subroutine interaction_evaluate_sum pure subroutine interaction_evaluate_me_sum (int, i, int1, index1) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1 integer, dimension(:), intent(in) :: index1 call int%state_matrix%evaluate_me_sum (i, int1%state_matrix, index1) end subroutine interaction_evaluate_me_sum @ %def interaction_evaluate_product @ %def interaction_evaluate_product_cf @ %def interaction_evaluate_square_c @ %def interaction_evaluate_sum @ %def interaction_evaluate_me_sum @ Tag quantum numbers of the state matrix as part of the hard process, according to the indices specified in [[tag]]. If no [[tag]] is given, all quantum numbers are tagged as part of the hard process. <>= procedure :: tag_hard_process => interaction_tag_hard_process <>= subroutine interaction_tag_hard_process (int, tag) class(interaction_t), intent(inout) :: int integer, dimension(:), intent(in), optional :: tag type(state_matrix_t) :: state call int%state_matrix%tag_hard_process (state, tag) call int%state_matrix%final () int%state_matrix = state end subroutine interaction_tag_hard_process @ %def interaction_tag_hard_process \subsection{Accessing contents} Return the integer tag. <>= procedure :: get_tag => interaction_get_tag <>= function interaction_get_tag (int) result (tag) class(interaction_t), intent(in) :: int integer :: tag tag = int%tag end function interaction_get_tag @ %def interaction_get_tag @ Return the number of particles. <>= procedure :: get_n_tot => interaction_get_n_tot procedure :: get_n_in => interaction_get_n_in procedure :: get_n_vir => interaction_get_n_vir procedure :: get_n_out => interaction_get_n_out <>= pure function interaction_get_n_tot (object) result (n_tot) class(interaction_t), intent(in) :: object integer :: n_tot n_tot = object%n_tot end function interaction_get_n_tot pure function interaction_get_n_in (object) result (n_in) class(interaction_t), intent(in) :: object integer :: n_in n_in = object%n_in end function interaction_get_n_in pure function interaction_get_n_vir (object) result (n_vir) class(interaction_t), intent(in) :: object integer :: n_vir n_vir = object%n_vir end function interaction_get_n_vir pure function interaction_get_n_out (object) result (n_out) class(interaction_t), intent(in) :: object integer :: n_out n_out = object%n_out end function interaction_get_n_out @ %def interaction_get_n_tot @ %def interaction_get_n_in interaction_get_n_vir interaction_get_n_out @ Return a momentum index. The flags specify whether to keep/drop incoming, virtual, or outgoing momenta. Check for illegal values. <>= function idx (int, i, outgoing) integer :: idx type(interaction_t), intent(in) :: int integer, intent(in) :: i logical, intent(in), optional :: outgoing logical :: in, vir, out if (present (outgoing)) then in = .not. outgoing vir = .false. out = outgoing else in = .true. vir = .true. out = .true. end if idx = 0 if (in) then if (vir) then if (out) then if (i <= int%n_tot) idx = i else if (i <= int%n_in + int%n_vir) idx = i end if else if (out) then if (i <= int%n_in) then idx = i else if (i <= int%n_in + int%n_out) then idx = int%n_vir + i end if else if (i <= int%n_in) idx = i end if else if (vir) then if (out) then if (i <= int%n_vir + int%n_out) idx = int%n_in + i else if (i <= int%n_vir) idx = int%n_in + i end if else if (out) then if (i <= int%n_out) idx = int%n_in + int%n_vir + i end if if (idx == 0) then call int%basic_write () print *, i, in, vir, out call msg_bug (" Momentum index is out of range for this interaction") end if end function idx @ %def idx @ Return all or just a specific four-momentum. <>= generic :: get_momenta => get_momenta_all, get_momenta_idx procedure :: get_momentum => interaction_get_momentum procedure :: get_momenta_all => interaction_get_momenta_all procedure :: get_momenta_idx => interaction_get_momenta_idx <>= function interaction_get_momenta_all (int, outgoing) result (p) class(interaction_t), intent(in) :: int type(vector4_t), dimension(:), allocatable :: p logical, intent(in), optional :: outgoing integer :: i if (present (outgoing)) then if (outgoing) then allocate (p (int%n_out)) else allocate (p (int%n_in)) end if else allocate (p (int%n_tot)) end if do i = 1, size (p) p(i) = int%p(idx (int, i, outgoing)) end do end function interaction_get_momenta_all function interaction_get_momenta_idx (int, jj) result (p) class(interaction_t), intent(in) :: int type(vector4_t), dimension(:), allocatable :: p integer, dimension(:), intent(in) :: jj allocate (p (size (jj))) p = int%p(jj) end function interaction_get_momenta_idx function interaction_get_momentum (int, i, outgoing) result (p) class(interaction_t), intent(in) :: int type(vector4_t) :: p integer, intent(in) :: i logical, intent(in), optional :: outgoing p = int%p(idx (int, i, outgoing)) end function interaction_get_momentum @ %def interaction_get_momenta interaction_get_momentum @ Return a shallow copy of the state matrix: <>= procedure :: get_state_matrix_ptr => & interaction_get_state_matrix_ptr <>= function interaction_get_state_matrix_ptr (int) result (state) class(interaction_t), intent(in), target :: int type(state_matrix_t), pointer :: state state => int%state_matrix end function interaction_get_state_matrix_ptr @ %def interaction_get_state_matrix_ptr @ Return the array of resonance flags <>= procedure :: get_resonance_flags => interaction_get_resonance_flags <>= function interaction_get_resonance_flags (int) result (resonant) class(interaction_t), intent(in) :: int logical, dimension(size(int%resonant)) :: resonant resonant = int%resonant end function interaction_get_resonance_flags @ %def interaction_get_resonance_flags @ Return the quantum-numbers mask (or part of it) <>= generic :: get_mask => get_mask_all, get_mask_slice procedure :: get_mask_all => interaction_get_mask_all procedure :: get_mask_slice => interaction_get_mask_slice <>= function interaction_get_mask_all (int) result (mask) class(interaction_t), intent(in) :: int type(quantum_numbers_mask_t), dimension(size(int%mask)) :: mask mask = int%mask end function interaction_get_mask_all function interaction_get_mask_slice (int, index) result (mask) class(interaction_t), intent(in) :: int integer, dimension(:), intent(in) :: index type(quantum_numbers_mask_t), dimension(size(index)) :: mask mask = int%mask(index) end function interaction_get_mask_slice @ %def interaction_get_mask @ Compute the invariant mass squared of the incoming particles (if any, otherwise outgoing). <>= public :: interaction_get_s <>= function interaction_get_s (int) result (s) real(default) :: s type(interaction_t), intent(in) :: int if (int%n_in /= 0) then s = sum (int%p(:int%n_in)) ** 2 else s = sum (int%p(int%n_vir + 1 : )) ** 2 end if end function interaction_get_s @ %def interaction_get_s @ Compute the Lorentz transformation that transforms the incoming particles from the center-of-mass frame to the lab frame where they are given. If the c.m. mass squared is negative or zero, return the identity. <>= public :: interaction_get_cm_transformation <>= function interaction_get_cm_transformation (int) result (lt) type(lorentz_transformation_t) :: lt type(interaction_t), intent(in) :: int type(vector4_t) :: p_cm real(default) :: s if (int%n_in /= 0) then p_cm = sum (int%p(:int%n_in)) else p_cm = sum (int%p(int%n_vir+1:)) end if s = p_cm ** 2 if (s > 0) then lt = boost (p_cm, sqrt (s)) else lt = identity end if end function interaction_get_cm_transformation @ %def interaction_get_cm_transformation @ Return flavor, momentum, and position of the first outgoing unstable particle present in the interaction. Note that we need not iterate through the state matrix; if there is an unstable particle, it will be present in all state-matrix entries. <>= public :: interaction_get_unstable_particle <>= subroutine interaction_get_unstable_particle (int, flv, p, i) type(interaction_t), intent(in), target :: int type(flavor_t), intent(out) :: flv type(vector4_t), intent(out) :: p integer, intent(out) :: i type(state_iterator_t) :: it type(flavor_t), dimension(int%n_tot) :: flv_array call it%init (int%state_matrix) flv_array = it%get_flavor () do i = int%n_in + int%n_vir + 1, int%n_tot if (.not. flv_array(i)%is_stable ()) then flv = flv_array(i) p = int%p(i) return end if end do end subroutine interaction_get_unstable_particle @ %def interaction_get_unstable_particle @ Return the complete set of \emph{outgoing} flavors, assuming that the flavor quantum number is not suppressed. <>= public :: interaction_get_flv_out <>= subroutine interaction_get_flv_out (int, flv) type(interaction_t), intent(in), target :: int type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv type(state_iterator_t) :: it type(flavor_t), dimension(:), allocatable :: flv_state integer :: n_in, n_vir, n_out, n_tot, n_state, i n_in = int%get_n_in () n_vir = int%get_n_vir () n_out = int%get_n_out () n_tot = int%get_n_tot () n_state = int%get_n_matrix_elements () allocate (flv (n_out, n_state)) allocate (flv_state (n_tot)) i = 1 call it%init (int%get_state_matrix_ptr ()) do while (it%is_valid ()) flv_state = it%get_flavor () flv(:,i) = flv_state(n_in + n_vir + 1 : ) i = i + 1 call it%advance () end do end subroutine interaction_get_flv_out @ %def interaction_get_flv_out @ Determine the flavor content of the interaction. We analyze the state matrix for this, and we select the outgoing particles of the hard process only for the required mask, which indicates the particles that can appear in any order in a matching event record. We have to assume that any radiated particles (beam remnants) appear at the beginning of the particles marked as outgoing. <>= public :: interaction_get_flv_content <>= subroutine interaction_get_flv_content (int, state_flv, n_out_hard) type(interaction_t), intent(in), target :: int type(state_flv_content_t), intent(out) :: state_flv integer, intent(in) :: n_out_hard logical, dimension(:), allocatable :: mask integer :: n_tot n_tot = int%get_n_tot () allocate (mask (n_tot), source = .false.) mask(n_tot-n_out_hard + 1 : ) = .true. call state_flv%fill (int%get_state_matrix_ptr (), mask) end subroutine interaction_get_flv_content @ %def interaction_get_flv_content @ \subsection{Modifying contents} Set the quantum numbers mask. <>= procedure :: set_mask => interaction_set_mask <>= subroutine interaction_set_mask (int, mask) class(interaction_t), intent(inout) :: int type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask if (size (int%mask) /= size (mask)) & call msg_fatal ("Attempting to set mask with unfitting size!") int%mask = mask int%update_state_matrix = .true. end subroutine interaction_set_mask @ %def interaction_set_mask @ Merge a particular mask entry, respecting a possible helicity lock for this entry. We apply an OR relation, which means that quantum numbers are summed over if either of the two masks requires it. <>= subroutine interaction_merge_mask_entry (int, i, mask) type(interaction_t), intent(inout) :: int integer, intent(in) :: i type(quantum_numbers_mask_t), intent(in) :: mask type(quantum_numbers_mask_t) :: mask_tmp integer :: ii ii = idx (int, i) if (int%mask(ii) .neqv. mask) then int%mask(ii) = int%mask(ii) .or. mask if (int%hel_lock(ii) /= 0) then call mask_tmp%assign (mask, helicity=.true.) int%mask(int%hel_lock(ii)) = int%mask(int%hel_lock(ii)) .or. mask_tmp end if end if int%update_state_matrix = .true. end subroutine interaction_merge_mask_entry @ %def interaction_merge_mask_entry @ Fill the momenta array, do not care about the quantum numbers of particles. <>= procedure :: reset_momenta => interaction_reset_momenta procedure :: set_momenta => interaction_set_momenta procedure :: set_momentum => interaction_set_momentum <>= subroutine interaction_reset_momenta (int) class(interaction_t), intent(inout) :: int int%p = vector4_null int%p_is_known = .true. end subroutine interaction_reset_momenta subroutine interaction_set_momenta (int, p, outgoing) class(interaction_t), intent(inout) :: int type(vector4_t), dimension(:), intent(in) :: p logical, intent(in), optional :: outgoing integer :: i, index do i = 1, size (p) index = idx (int, i, outgoing) int%p(index) = p(i) int%p_is_known(index) = .true. end do end subroutine interaction_set_momenta subroutine interaction_set_momentum (int, p, i, outgoing) class(interaction_t), intent(inout) :: int type(vector4_t), intent(in) :: p integer, intent(in) :: i logical, intent(in), optional :: outgoing integer :: index index = idx (int, i, outgoing) int%p(index) = p int%p_is_known(index) = .true. end subroutine interaction_set_momentum @ %def interaction_reset_momenta @ %def interaction_set_momenta interaction_set_momentum @ This more sophisticated version of setting values is used for structure functions, in particular if nontrivial flavor, color, and helicity may be present: set values selectively for the given flavors. If there is more than one flavor, scan the interaction and check for a matching flavor at the specified particle location. If it matches, insert the value that corresponds to this flavor. <>= public :: interaction_set_flavored_values <>= subroutine interaction_set_flavored_values (int, value, flv_in, pos) type(interaction_t), intent(inout) :: int complex(default), dimension(:), intent(in) :: value type(flavor_t), dimension(:), intent(in) :: flv_in integer, intent(in) :: pos type(state_iterator_t) :: it type(flavor_t) :: flv integer :: i if (size (value) == 1) then call int%set_matrix_element (value(1)) else call it%init (int%state_matrix) do while (it%is_valid ()) flv = it%get_flavor (pos) SCAN_FLV: do i = 1, size (value) if (flv == flv_in(i)) then call it%set_matrix_element (value(i)) exit SCAN_FLV end if end do SCAN_FLV call it%advance () end do end if end subroutine interaction_set_flavored_values @ %def interaction_set_flavored_values @ \subsection{Handling Linked interactions} Store relations between corresponding particles within one interaction. The first particle is the parent, the second one the child. Links are established in both directions. These relations have no effect on the propagation of momenta etc., they are rather used for mother-daughter relations in event output. <>= procedure :: relate => interaction_relate <>= subroutine interaction_relate (int, i1, i2) class(interaction_t), intent(inout), target :: int integer, intent(in) :: i1, i2 if (i1 /= 0 .and. i2 /= 0) then call int%children(i1)%append (i2) call int%parents(i2)%append (i1) end if end subroutine interaction_relate @ %def interaction_relate @ Transfer internal parent-child relations defined within interaction [[int1]] to a new interaction [[int]] where the particle indices are mapped to. Some particles in [[int1]] may have no image in [[int]]. In that case, a child entry maps to zero, and we skip this relation. Also transfer resonance flags. <>= procedure :: transfer_relations => interaction_transfer_relations <>= subroutine interaction_transfer_relations (int1, int2, map) class(interaction_t), intent(in) :: int1 class(interaction_t), intent(inout), target :: int2 integer, dimension(:), intent(in) :: map integer :: i, j, k do i = 1, size (map) do j = 1, int1%parents(i)%get_length () k = int1%parents(i)%get_link (j) call int2%relate (map(k), map(i)) end do if (map(i) /= 0) then int2%resonant(map(i)) = int1%resonant(i) end if end do end subroutine interaction_transfer_relations @ %def interaction_transfer_relations @ Make up internal parent-child relations for the particle(s) that are connected to a new interaction [[int]]. If [[resonant]] is defined and true, the connections are marked as resonant in the result interaction <>= procedure :: relate_connections => interaction_relate_connections <>= subroutine interaction_relate_connections & (int, int_in, connection_index, & map, map_connections, resonant) class(interaction_t), intent(inout), target :: int class(interaction_t), intent(in) :: int_in integer, dimension(:), intent(in) :: connection_index integer, dimension(:), intent(in) :: map, map_connections logical, intent(in), optional :: resonant logical :: reson integer :: i, j, i2, k2 reson = .false.; if (present (resonant)) reson = resonant do i = 1, size (map_connections) k2 = connection_index(i) do j = 1, int_in%children(k2)%get_length () i2 = int_in%children(k2)%get_link (j) call int%relate (map_connections(i), map(i2)) end do int%resonant(map_connections(i)) = reson end do end subroutine interaction_relate_connections @ %def interaction_relate_connections. @ Return the number of source/target links of the internal connections of particle [[i]]. <>= public :: interaction_get_n_children public :: interaction_get_n_parents <>= function interaction_get_n_children (int, i) result (n) integer :: n type(interaction_t), intent(in) :: int integer, intent(in) :: i n = int%children(i)%get_length () end function interaction_get_n_children function interaction_get_n_parents (int, i) result (n) integer :: n type(interaction_t), intent(in) :: int integer, intent(in) :: i n = int%parents(i)%get_length () end function interaction_get_n_parents @ %def interaction_get_n_children interaction_get_n_parents @ Return the source/target links of the internal connections of particle [[i]] as an array. <>= public :: interaction_get_children public :: interaction_get_parents <>= function interaction_get_children (int, i) result (idx) integer, dimension(:), allocatable :: idx type(interaction_t), intent(in) :: int integer, intent(in) :: i integer :: k, l l = int%children(i)%get_length () allocate (idx (l)) do k = 1, l idx(k) = int%children(i)%get_link (k) end do end function interaction_get_children function interaction_get_parents (int, i) result (idx) integer, dimension(:), allocatable :: idx type(interaction_t), intent(in) :: int integer, intent(in) :: i integer :: k, l l = int%parents(i)%get_length () allocate (idx (l)) do k = 1, l idx(k) = int%parents(i)%get_link (k) end do end function interaction_get_parents @ %def interaction_get_children interaction_get_parents @ Add a source link from an interaction to a corresponding particle within another interaction. These links affect the propagation of particles: the two linked particles are considered as the same particle, outgoing and incoming. <>= procedure :: set_source_link => interaction_set_source_link <>= subroutine interaction_set_source_link (int, i, int1, i1) class(interaction_t), intent(inout) :: int integer, intent(in) :: i class(interaction_t), intent(in), target :: int1 integer, intent(in) :: i1 if (i /= 0) call external_link_set (int%source(i), int1, i1) end subroutine interaction_set_source_link @ %def interaction_set_source_link @ Reassign links to a new interaction (which is an image of the current interaction). <>= public :: interaction_reassign_links <>= subroutine interaction_reassign_links (int, int_src, int_target) type(interaction_t), intent(inout) :: int type(interaction_t), intent(in) :: int_src type(interaction_t), intent(in), target :: int_target integer :: i if (allocated (int%source)) then do i = 1, size (int%source) call external_link_reassign (int%source(i), int_src, int_target) end do end if end subroutine interaction_reassign_links @ %def interaction_reassign_links @ Since links are one-directional, if we want to follow them backwards we have to scan all possibilities. This procedure returns the index of the particle within [[int]] which points to the particle [[i1]] within interaction [[int1]]. If unsuccessful, return zero. <>= public :: interaction_find_link <>= function interaction_find_link (int, int1, i1) result (i) integer :: i type(interaction_t), intent(in) :: int, int1 integer, intent(in) :: i1 type(interaction_t), pointer :: int_tmp do i = 1, int%n_tot int_tmp => external_link_get_ptr (int%source(i)) if (int_tmp%tag == int1%tag) then if (external_link_get_index (int%source(i)) == i1) return end if end do i = 0 end function interaction_find_link @ %def interaction_find_link @ The inverse: return interaction pointer and index for the ultimate source of [[i]] within [[int]]. <>= procedure :: find_source => interaction_find_source <>= subroutine interaction_find_source (int, i, int1, i1) class(interaction_t), intent(in) :: int integer, intent(in) :: i type(interaction_t), intent(out), pointer :: int1 integer, intent(out) :: i1 type(external_link_t) :: link link = interaction_get_ultimate_source (int, i) int1 => external_link_get_ptr (link) i1 = external_link_get_index (link) end subroutine interaction_find_source @ %def interaction_find_source @ Follow source links recursively to return the ultimate source of a particle. <>= function interaction_get_ultimate_source (int, i) result (link) type(external_link_t) :: link type(interaction_t), intent(in) :: int integer, intent(in) :: i type(interaction_t), pointer :: int_src integer :: i_src link = int%source(i) if (external_link_is_set (link)) then do int_src => external_link_get_ptr (link) i_src = external_link_get_index (link) if (external_link_is_set (int_src%source(i_src))) then link = int_src%source(i_src) else exit end if end do end if end function interaction_get_ultimate_source @ %def interaction_get_ultimate_source @ Update mask entries by merging them with corresponding masks in interactions linked to the current one. The mask determines quantum numbers which are summed over. Note that both the mask of the current interaction and the mask of the linked interaction are updated (side effect!). This ensures that both agree for the linked particle. <>= public :: interaction_exchange_mask <>= subroutine interaction_exchange_mask (int) type(interaction_t), intent(inout) :: int integer :: i, index_link type(interaction_t), pointer :: int_link do i = 1, int%n_tot if (external_link_is_set (int%source(i))) then int_link => external_link_get_ptr (int%source(i)) index_link = external_link_get_index (int%source(i)) call interaction_merge_mask_entry & (int, i, int_link%mask(index_link)) call interaction_merge_mask_entry & (int_link, index_link, int%mask(i)) end if end do call int%freeze () end subroutine interaction_exchange_mask @ %def interaction_exchange_mask @ Copy momenta from interactions linked to the current one. <>= procedure :: receive_momenta => interaction_receive_momenta <>= subroutine interaction_receive_momenta (int) class(interaction_t), intent(inout) :: int integer :: i, index_link type(interaction_t), pointer :: int_link do i = 1, int%n_tot if (external_link_is_set (int%source(i))) then int_link => external_link_get_ptr (int%source(i)) index_link = external_link_get_index (int%source(i)) call int%set_momentum (int_link%p(index_link), i) end if end do end subroutine interaction_receive_momenta @ %def interaction_receive_momenta @ The inverse operation: Copy momenta back to the interactions linked to the current one. <>= public :: interaction_send_momenta <>= subroutine interaction_send_momenta (int) type(interaction_t), intent(in) :: int integer :: i, index_link type(interaction_t), pointer :: int_link do i = 1, int%n_tot if (external_link_is_set (int%source(i))) then int_link => external_link_get_ptr (int%source(i)) index_link = external_link_get_index (int%source(i)) call int_link%set_momentum (int%p(i), index_link) end if end do end subroutine interaction_send_momenta @ %def interaction_send_momenta @ For numerical comparisons: pacify all momenta in an interaction. <>= public :: interaction_pacify_momenta <>= subroutine interaction_pacify_momenta (int, acc) type(interaction_t), intent(inout) :: int real(default), intent(in) :: acc integer :: i do i = 1, int%n_tot call pacify (int%p(i), acc) end do end subroutine interaction_pacify_momenta @ %def interaction_pacify_momenta @ For each subtraction entry starting from [[SUB = 0]], we duplicate the original state matrix entries as is. <>= procedure :: declare_subtraction => interaction_declare_subtraction <>= subroutine interaction_declare_subtraction (int, n_sub) class(interaction_t), intent(inout), target :: int integer, intent(in) :: n_sub integer :: i_sub type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn type(state_matrix_t) :: state_matrix call state_matrix%init (store_values = .true.) allocate (qn (int%get_state_depth ())) do i_sub = 0, n_sub call it%init (int%state_matrix) do while (it%is_valid ()) qn = it%get_quantum_numbers () call qn%set_subtraction_index (i_sub) call state_matrix%add_state (qn, value = it%get_matrix_element ()) call it%advance () end do end do call state_matrix%freeze () call state_matrix%set_n_sub () call int%state_matrix%final () int%state_matrix = state_matrix end subroutine interaction_declare_subtraction @ %def interaction_declare_subtraction @ \subsection{Recovering connections} When creating an evaluator for two interactions, we have to know by which particles they are connected. The connection indices can be determined if we have two linked interactions. We assume that [[int1]] is the source and [[int2]] the target, so the connections of interest are stored within [[int2]]. A connection is found if either the source is [[int1]], or the (ultimate) source of a particle within [[int2]] coincides with the (ultimate) source of a particle within [[int1]]. The result is an array of index pairs. To make things simple, we scan the interaction twice, once for counting hits, then allocate the array, then scan again and store the connections. The connections are scanned for [[int2]], which has sources in [[int1]]. It may happen that the order of connections is interchanged (crossed). We require the indices in [[int1]] to be sorted, so we reorder both index arrays correspondingly before returning them. (After this, the indices in [[int2]] may be out of order.) <>= public :: find_connections <>= subroutine find_connections (int1, int2, n, connection_index) class(interaction_t), intent(in) :: int1, int2 integer, intent(out) :: n integer, dimension(:,:), intent(out), allocatable :: connection_index integer, dimension(:,:), allocatable :: conn_index_tmp integer, dimension(:), allocatable :: ordering integer :: i, j, k type(external_link_t) :: link1, link2 type(interaction_t), pointer :: int_link1, int_link2 n = 0 do i = 1, size (int2%source) link2 = interaction_get_ultimate_source (int2, i) if (external_link_is_set (link2)) then int_link2 => external_link_get_ptr (link2) if (int_link2%tag == int1%tag) then n = n + 1 else k = external_link_get_index (link2) do j = 1, size (int1%source) link1 = interaction_get_ultimate_source (int1, j) if (external_link_is_set (link1)) then int_link1 => external_link_get_ptr (link1) if (int_link1%tag == int_link2%tag) then if (external_link_get_index (link1) == k) & n = n + 1 end if end if end do end if end if end do allocate (conn_index_tmp (n, 2)) n = 0 do i = 1, size (int2%source) link2 = interaction_get_ultimate_source (int2, i) if (external_link_is_set (link2)) then int_link2 => external_link_get_ptr (link2) if (int_link2%tag == int1%tag) then n = n + 1 conn_index_tmp(n,1) = external_link_get_index (int2%source(i)) conn_index_tmp(n,2) = i else k = external_link_get_index (link2) do j = 1, size (int1%source) link1 = interaction_get_ultimate_source (int1, j) if (external_link_is_set (link1)) then int_link1 => external_link_get_ptr (link1) if (int_link1%tag == int_link2%tag) then if (external_link_get_index (link1) == k) then n = n + 1 conn_index_tmp(n,1) = j conn_index_tmp(n,2) = i end if end if end if end do end if end if end do allocate (connection_index (n, 2)) if (n > 1) then allocate (ordering (n)) ordering = order (conn_index_tmp(:,1)) connection_index = conn_index_tmp(ordering,:) else connection_index = conn_index_tmp end if end subroutine find_connections @ %def find_connections @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[interactions_ut.f90]]>>= <> module interactions_ut use unit_tests use interactions_uti <> <> contains <> end module interactions_ut @ %def interactions_ut @ <<[[interactions_uti.f90]]>>= <> module interactions_uti <> use lorentz use flavors use colors use helicities use quantum_numbers use state_matrices use interactions <> <> contains <> end module interactions_uti @ %def interactions_ut @ API: driver for the unit tests below. <>= public :: interaction_test <>= subroutine interaction_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine interaction_test @ %def interaction_test @ Generate an interaction of a polarized virtual photon and a colored quark which may be either up or down. Remove the quark polarization. Generate another interaction for the quark radiating a photon and link this to the first interation. The radiation ignores polarization; transfer this information to the first interaction to simplify it. Then, transfer the momentum to the radiating quark and perform a splitting. <>= call test (interaction_1, "interaction_1", & "check interaction setup", & u, results) <>= public :: interaction_1 <>= subroutine interaction_1 (u) integer, intent(in) :: u type(interaction_t), target :: int, rad type(vector4_t), dimension(3) :: p type(quantum_numbers_mask_t), dimension(3) :: mask p(2) = vector4_moving (500._default, 500._default, 1) p(3) = vector4_moving (500._default,-500._default, 1) p(1) = p(2) + p(3) write (u, "(A)") "* Test output: interaction" write (u, "(A)") "* Purpose: check routines for interactions" write (u, "(A)") call int%basic_init (1, 0, 2, set_relations=.true., & store_values = .true. ) call int_set (int, 1, -1, 1, 1, & cmplx (0.3_default, 0.1_default, kind=default)) call int_set (int, 1, -1,-1, 1, & cmplx (0.5_default,-0.7_default, kind=default)) call int_set (int, 1, 1, 1, 1, & cmplx (0.1_default, 0._default, kind=default)) call int_set (int, -1, 1, -1, 2, & cmplx (0.4_default, -0.1_default, kind=default)) call int_set (int, 1, 1, 1, 2, & cmplx (0.2_default, 0._default, kind=default)) call int%freeze () call int%set_momenta (p) mask = quantum_numbers_mask (.false.,.false., [.true.,.true.,.true.]) call rad%basic_init (1, 0, 2, & mask=mask, set_relations=.true., store_values = .true.) call rad_set (1) call rad_set (2) call rad%set_source_link (1, int, 2) call interaction_exchange_mask (rad) call rad%receive_momenta () p(1) = rad%get_momentum (1) p(2) = 0.4_default * p(1) p(3) = p(1) - p(2) call rad%set_momenta (p(2:3), outgoing=.true.) call int%freeze () call rad%freeze () call rad%set_matrix_element & (cmplx (0._default, 0._default, kind=default)) call int%basic_write (u) write (u, "(A)") call rad%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call rad%final () write (u, "(A)") write (u, "(A)") "* Test interaction_1: successful." contains subroutine int_set (int, h1, h2, hq, q, val) type(interaction_t), target, intent(inout) :: int integer, intent(in) :: h1, h2, hq, q type(flavor_t), dimension(3) :: flv type(color_t), dimension(3) :: col type(helicity_t), dimension(3) :: hel type(quantum_numbers_t), dimension(3) :: qn complex(default), intent(in) :: val call flv%init ([21, q, -q]) call col(2)%init_col_acl (5, 0) call col(3)%init_col_acl (0, 5) call hel%init ([h1, hq, -hq], [h2, hq, -hq]) call qn%init (flv, col, hel) call int%add_state (qn) call int%set_matrix_element (val) end subroutine int_set subroutine rad_set (q) integer, intent(in) :: q type(flavor_t), dimension(3) :: flv type(quantum_numbers_t), dimension(3) :: qn call flv%init ([ q, q, 21 ]) call qn%init (flv) call rad%add_state (qn) end subroutine rad_set end subroutine interaction_1 @ %def interaction_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Matrix element evaluation} The [[evaluator_t]] type is an extension of the [[interaction_t]] type. It represents either a density matrix as the square of a transition matrix element, or the product of two density matrices. Usually, some quantum numbers are summed over in the result. The [[interaction_t]] subobject represents a multi-particle interaction with incoming, virtual, and outgoing particles and the associated (not necessarily diagonal) density matrix of quantum state. When the evaluator is initialized, this interaction is constructed from the input interaction(s). In addition, the initialization process sets up a multiplication table. For each matrix element of the result, it states which matrix elements are to be taken from the input interaction(s), multiplied (optionally, with an additional weight factor) and summed over. Eventually, to a processes we associate a chain of evaluators which are to be evaluated sequentially. The physical event and its matrix element value(s) can be extracted from the last evaluator in such a chain. Evaluators are constructed only once (as long as this is possible) during an initialization step. Then, for each event, momenta are computed and transferred among evaluators using the links within the interaction subobject. The multiplication tables enable fast evaluation of the result without looking at quantum numbers anymore. <<[[evaluators.f90]]>>= <> module evaluators <> <> use io_units use format_defs, only: FMT_19 use physics_defs, only: n_beams_rescaled use diagnostics use lorentz use flavors use colors use helicities use quantum_numbers use state_matrices use interactions <> <> <> <> <> contains <> end module evaluators @ %def evaluators @ \subsection{Array of pairings} The evaluator contains an array of [[pairing_array]] objects. This makes up the multiplication table. Each pairing array contains two list of matrix element indices and a list of numerical factors. The matrix element indices correspond to the input interactions. The corresponding matrix elements are to be multiplied and optionally multiplied by a factor. The results are summed over to yield one specific matrix element of the result evaluator. <>= type :: pairing_array_t integer, dimension(:), allocatable :: i1, i2 complex(default), dimension(:), allocatable :: factor end type pairing_array_t @ %def pairing_array_t <>= elemental subroutine pairing_array_init (pa, n, has_i2, has_factor) type(pairing_array_t), intent(out) :: pa integer, intent(in) :: n logical, intent(in) :: has_i2, has_factor allocate (pa%i1 (n)) if (has_i2) allocate (pa%i2 (n)) if (has_factor) allocate (pa%factor (n)) end subroutine pairing_array_init @ %def pairing_array_init @ <>= public :: pairing_array_write <>= subroutine pairing_array_write (pa, unit) type(pairing_array_t), intent(in) :: pa integer, intent(in), optional :: unit integer :: i, u u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance = "no") "[" if (allocated (pa%i1)) then write (u, "(I0,A)", advance = "no") pa%i1, "," else write (u, "(A)", advance = "no") "x," end if if (allocated (pa%i2)) then write (u, "(I0,A)", advance = "no") pa%i1, "," else write (u, "(A)", advance = "no") "x," end if write (u, "(A)", advance = "no") "]" if (allocated (pa%factor)) then write (u, "(A,F5.4,A,F5.4,A)") ";(", & real(pa%factor), ",", aimag(pa%factor), ")]" else write (u, "(A)") "" end if end subroutine pairing_array_write @ %def pairing_array_write @ \subsection{The evaluator type} Possible variants of evaluators: <>= integer, parameter :: & EVAL_UNDEFINED = 0, & EVAL_PRODUCT = 1, & EVAL_SQUARED_FLOWS = 2, & EVAL_SQUARE_WITH_COLOR_FACTORS = 3, & EVAL_COLOR_CONTRACTION = 4, & EVAL_IDENTITY = 5, & EVAL_QN_SUM = 6 @ %def EVAL_PRODUCT EVAL_SQUARED_FLOWS EVAL_SQUARE_WITH_COLOR_FACTORS @ %def EVAL_COLOR_CONTRACTION EVAL_QN_SUM @ The evaluator type contains the result interaction and an array of pairing lists, one for each matrix element in the result interaction. <>= public :: evaluator_t <>= type, extends (interaction_t) :: evaluator_t private integer :: type = EVAL_UNDEFINED class(interaction_t), pointer :: int_in1 => null () class(interaction_t), pointer :: int_in2 => null () type(pairing_array_t), dimension(:), allocatable :: pairing_array contains <> end type evaluator_t @ %def evaluator_t @ Output. <>= procedure :: write => evaluator_write <>= subroutine evaluator_write (eval, unit, & verbose, show_momentum_sum, show_mass, show_state, show_table, & col_verbose, testflag) class(evaluator_t), intent(in) :: eval integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, show_momentum_sum, show_mass logical, intent(in), optional :: show_state, show_table, col_verbose logical, intent(in), optional :: testflag logical :: conjugate, square, show_tab integer :: u u = given_output_unit (unit); if (u < 0) return show_tab = .true.; if (present (show_table)) show_tab = .false. call eval%basic_write & (unit, verbose, show_momentum_sum, show_mass, & show_state, col_verbose, testflag) if (show_tab) then write (u, "(1x,A)") "Matrix-element multiplication" write (u, "(2x,A)", advance="no") "Input interaction 1:" if (associated (eval%int_in1)) then write (u, "(1x,I0)") eval%int_in1%get_tag () else write (u, "(A)") " [undefined]" end if write (u, "(2x,A)", advance="no") "Input interaction 2:" if (associated (eval%int_in2)) then write (u, "(1x,I0)") eval%int_in2%get_tag () else write (u, "(A)") " [undefined]" end if select case (eval%type) case (EVAL_SQUARED_FLOWS, EVAL_SQUARE_WITH_COLOR_FACTORS) conjugate = .true. square = .true. case (EVAL_IDENTITY) write (u, "(1X,A)") "Identity evaluator, pairing array unused" return case default conjugate = .false. square = .false. end select call eval%write_pairing_array (conjugate, square, u) end if end subroutine evaluator_write @ %def evaluator_write @ <>= procedure :: write_pairing_array => evaluator_write_pairing_array <>= subroutine evaluator_write_pairing_array (eval, conjugate, square, unit) class(evaluator_t), intent(in) :: eval logical, intent(in) :: conjugate, square integer, intent(in), optional :: unit integer :: u, i, j u = given_output_unit (unit); if (u < 0) return if (allocated (eval%pairing_array)) then do i = 1, size (eval%pairing_array) write (u, "(2x,A,I0,A)") "ME(", i, ") = " do j = 1, size (eval%pairing_array(i)%i1) write (u, "(4x,A)", advance="no") "+" if (allocated (eval%pairing_array(i)%i2)) then write (u, "(1x,A,I0,A)", advance="no") & "ME1(", eval%pairing_array(i)%i1(j), ")" if (conjugate) then write (u, "(A)", advance="no") "* x" else write (u, "(A)", advance="no") " x" end if write (u, "(1x,A,I0,A)", advance="no") & "ME2(", eval%pairing_array(i)%i2(j), ")" else if (square) then write (u, "(1x,A)", advance="no") "|" write (u, "(A,I0,A)", advance="no") & "ME1(", eval%pairing_array(i)%i1(j), ")" write (u, "(A)", advance="no") "|^2" else write (u, "(1x,A,I0,A)", advance="no") & "ME1(", eval%pairing_array(i)%i1(j), ")" end if if (allocated (eval%pairing_array(i)%factor)) then write (u, "(1x,A)", advance="no") "x" write (u, "(1x,'('," // FMT_19 // ",','," // FMT_19 // & ",')')") eval%pairing_array(i)%factor(j) else write (u, *) end if end do end do end if end subroutine evaluator_write_pairing_array @ %def evaluator_write_pairing_array @ Assignment: Deep copy of the interaction component. <>= public :: assignment(=) <>= interface assignment(=) module procedure evaluator_assign end interface <>= subroutine evaluator_assign (eval_out, eval_in) type(evaluator_t), intent(out) :: eval_out type(evaluator_t), intent(in) :: eval_in eval_out%type = eval_in%type eval_out%int_in1 => eval_in%int_in1 eval_out%int_in2 => eval_in%int_in2 eval_out%interaction_t = eval_in%interaction_t if (allocated (eval_in%pairing_array)) then allocate (eval_out%pairing_array (size (eval_in%pairing_array))) eval_out%pairing_array = eval_in%pairing_array end if end subroutine evaluator_assign @ %def evaluator_assign @ \subsection{Auxiliary structures for evaluator creation} Creating an evaluator that properly handles all quantum numbers requires some bookkeeping. In this section, we define several auxiliary types and methods that organize and simplify this task. More structures are defined within the specific initializers (as local types and internal subroutines). These types are currently implemented in a partial object-oriented way: We define some basic methods for initialization etc.\ here, but the evaluator routines below do access their internals as well. This simplifies some things such as index addressing using array slices, at the expense of losing some clarity. \subsubsection{Index mapping} Index mapping are abundant when constructing an evaluator. To have arrays of index mappings, we define this: <>= type :: index_map_t integer, dimension(:), allocatable :: entry end type index_map_t @ %def index_map_t <>= elemental subroutine index_map_init (map, n) type(index_map_t), intent(out) :: map integer, intent(in) :: n allocate (map%entry (n)) map%entry = 0 end subroutine index_map_init @ %def index_map_init <>= function index_map_exists (map) result (flag) logical :: flag type(index_map_t), intent(in) :: map flag = allocated (map%entry) end function index_map_exists @ %def index_map_exists <>= interface size module procedure index_map_size end interface @ %def size <>= function index_map_size (map) result (s) integer :: s type(index_map_t), intent(in) :: map if (allocated (map%entry)) then s = size (map%entry) else s = 0 end if end function index_map_size @ %def index_map_size <>= interface assignment(=) module procedure index_map_assign_int module procedure index_map_assign_array end interface @ %def = <>= elemental subroutine index_map_assign_int (map, ival) type(index_map_t), intent(inout) :: map integer, intent(in) :: ival map%entry = ival end subroutine index_map_assign_int subroutine index_map_assign_array (map, array) type(index_map_t), intent(inout) :: map integer, dimension(:), intent(in) :: array map%entry = array end subroutine index_map_assign_array @ %def index_map_assign_int index_map_assign_array <>= elemental subroutine index_map_set_entry (map, i, ival) type(index_map_t), intent(inout) :: map integer, intent(in) :: i integer, intent(in) :: ival map%entry(i) = ival end subroutine index_map_set_entry @ %def index_map_set_entry <>= elemental function index_map_get_entry (map, i) result (ival) integer :: ival type(index_map_t), intent(in) :: map integer, intent(in) :: i ival = map%entry(i) end function index_map_get_entry @ %def index_map_get_entry @ \subsubsection{Index mapping (two-dimensional)} This is a variant with a square matrix instead of an array. <>= type :: index_map2_t integer :: s = 0 integer, dimension(:,:), allocatable :: entry end type index_map2_t @ %def index_map2_t <>= elemental subroutine index_map2_init (map, n) type(index_map2_t), intent(out) :: map integer, intent(in) :: n map%s = n allocate (map%entry (n, n)) end subroutine index_map2_init @ %def index_map2_init <>= function index_map2_exists (map) result (flag) logical :: flag type(index_map2_t), intent(in) :: map flag = allocated (map%entry) end function index_map2_exists @ %def index_map2_exists <>= interface size module procedure index_map2_size end interface @ %def size <>= function index_map2_size (map) result (s) integer :: s type(index_map2_t), intent(in) :: map s = map%s end function index_map2_size @ %def index_map2_size <>= interface assignment(=) module procedure index_map2_assign_int end interface @ %def = <>= elemental subroutine index_map2_assign_int (map, ival) type(index_map2_t), intent(inout) :: map integer, intent(in) :: ival map%entry = ival end subroutine index_map2_assign_int @ %def index_map2_assign_int <>= elemental subroutine index_map2_set_entry (map, i, j, ival) type(index_map2_t), intent(inout) :: map integer, intent(in) :: i, j integer, intent(in) :: ival map%entry(i,j) = ival end subroutine index_map2_set_entry @ %def index_map2_set_entry <>= elemental function index_map2_get_entry (map, i, j) result (ival) integer :: ival type(index_map2_t), intent(in) :: map integer, intent(in) :: i, j ival = map%entry(i,j) end function index_map2_get_entry @ %def index_map2_get_entry @ \subsubsection{Auxiliary structures: particle mask} This is a simple container of a logical array. <>= type :: prt_mask_t logical, dimension(:), allocatable :: entry end type prt_mask_t @ %def prt_mask_t <>= subroutine prt_mask_init (mask, n) type(prt_mask_t), intent(out) :: mask integer, intent(in) :: n allocate (mask%entry (n)) end subroutine prt_mask_init @ %def prt_mask_init <>= interface size module procedure prt_mask_size end interface @ %def size <>= function prt_mask_size (mask) result (s) integer :: s type(prt_mask_t), intent(in) :: mask s = size (mask%entry) end function prt_mask_size @ %def prt_mask_size @ \subsubsection{Quantum number containers} Trivial transparent containers: <>= type :: qn_list_t type(quantum_numbers_t), dimension(:,:), allocatable :: qn end type qn_list_t type :: qn_mask_array_t type(quantum_numbers_mask_t), dimension(:), allocatable :: mask end type qn_mask_array_t @ %def qn_list_t qn_mask_array_t @ \subsubsection{Auxiliary structures: connection entries} This type is used as intermediate storage when computing the product of two evaluators or the square of an evaluator. The quantum-number array [[qn]] corresponds to the particles common to both interactions, but irrelevant quantum numbers (color) masked out. The index arrays [[index_in]] determine the entries in the input interactions that contribute to this connection. [[n_index]] is the size of these arrays, and [[count]] is used while filling the entries. Finally, the quantum-number arrays [[qn_in_list]] are the actual entries in the input interaction that contribute. In the product case, they exclude the connected quantum numbers. Each evaluator has its own [[connection_table]] which contains an array of [[connection_entry]] objects, but also has stuff that specifically applies to the evaluator type. Hence, we do not generalize the [[connection_table_t]] type. The filling procedure [[connection_entry_add_state]] is specific to the various evaluator types. <>= type :: connection_entry_t type(quantum_numbers_t), dimension(:), allocatable :: qn_conn integer, dimension(:), allocatable :: n_index integer, dimension(:), allocatable :: count type(index_map_t), dimension(:), allocatable :: index_in type(qn_list_t), dimension(:), allocatable :: qn_in_list end type connection_entry_t @ %def connection_entry_t <>= subroutine connection_entry_init & (entry, n_count, n_map, qn_conn, count, n_rest) type(connection_entry_t), intent(out) :: entry integer, intent(in) :: n_count, n_map type(quantum_numbers_t), dimension(:), intent(in) :: qn_conn integer, dimension(n_count), intent(in) :: count integer, dimension(n_count), intent(in) :: n_rest integer :: i allocate (entry%qn_conn (size (qn_conn))) allocate (entry%n_index (n_count)) allocate (entry%count (n_count)) allocate (entry%index_in (n_map)) allocate (entry%qn_in_list (n_count)) entry%qn_conn = qn_conn entry%n_index = count entry%count = 0 if (size (entry%index_in) == size (count)) then call index_map_init (entry%index_in, count) else call index_map_init (entry%index_in, count(1)) end if do i = 1, n_count allocate (entry%qn_in_list(i)%qn (n_rest(i), count(i))) end do end subroutine connection_entry_init @ %def connection_entry_init <>= subroutine connection_entry_write (entry, unit) type(connection_entry_t), intent(in) :: entry integer, intent(in), optional :: unit integer :: i, j integer :: u u = given_output_unit (unit) call quantum_numbers_write (entry%qn_conn, unit) write (u, *) do i = 1, size (entry%n_index) write (u, *) "Input interaction", i do j = 1, entry%n_index(i) if (size (entry%n_index) == size (entry%index_in)) then write (u, "(2x,I0,4x,I0,2x)", advance = "no") & j, index_map_get_entry (entry%index_in(i), j) else write (u, "(2x,I0,4x,I0,2x,I0,2x)", advance = "no") & j, index_map_get_entry (entry%index_in(1), j), & index_map_get_entry (entry%index_in(2), j) end if call quantum_numbers_write (entry%qn_in_list(i)%qn(:,j), unit) write (u, *) end do end do end subroutine connection_entry_write @ %def connection_entry_write @ \subsubsection{Color handling} For managing color-factor computation, we introduce this local type. The [[index]] is the index in the color table that corresponds to a given matrix element index in the input interaction. The [[col]] array stores the color assignments in rows. The [[factor]] array associates a complex number with each pair of arrays in the color table. The [[factor_is_known]] array reveals whether a given factor is known already or still has to be computed. <>= type :: color_table_t integer, dimension(:), allocatable :: index type(color_t), dimension(:,:), allocatable :: col logical, dimension(:,:), allocatable :: factor_is_known complex(default), dimension(:,:), allocatable :: factor end type color_table_t @ %def color_table_t @ This is the initializer. We extract the color states from the given state matrices, establish index mappings between the two states (implemented by the array [[me_index]]), make an array of color states, and initialize the color-factor table. The latter is two-dimensional (includes interference) and not yet filled. <>= subroutine color_table_init (color_table, state, n_tot) type(color_table_t), intent(out) :: color_table type(state_matrix_t), intent(in) :: state integer, intent(in) :: n_tot type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn type(state_matrix_t) :: state_col integer :: index, n_col_state allocate (color_table%index (state%get_n_matrix_elements ())) color_table%index = 0 allocate (qn (n_tot)) call state_col%init () call it%init (state) do while (it%is_valid ()) index = it%get_me_index () call qn%init (col = it%get_color ()) call state_col%add_state (qn, me_index = color_table%index(index)) call it%advance () end do n_col_state = state_col%get_n_matrix_elements () allocate (color_table%col (n_tot, n_col_state)) call it%init (state_col) do while (it%is_valid ()) index = it%get_me_index () color_table%col(:,index) = it%get_color () call it%advance () end do call state_col%final () allocate (color_table%factor_is_known (n_col_state, n_col_state)) allocate (color_table%factor (n_col_state, n_col_state)) color_table%factor_is_known = .false. end subroutine color_table_init @ %def color_table_init @ Output (debugging use): <>= subroutine color_table_write (color_table, unit) type(color_table_t), intent(in) :: color_table integer, intent(in), optional :: unit integer :: i, j integer :: u u = given_output_unit (unit) write (u, *) "Color table:" if (allocated (color_table%index)) then write (u, *) " Index mapping state => color table:" do i = 1, size (color_table%index) write (u, "(3x,I0,2x,I0,2x)") i, color_table%index(i) end do write (u, *) " Color table:" do i = 1, size (color_table%col, 2) write (u, "(3x,I0,2x)", advance = "no") i call color_write (color_table%col(:,i), unit) write (u, *) end do write (u, *) " Defined color factors:" do i = 1, size (color_table%factor, 1) do j = 1, size (color_table%factor, 2) if (color_table%factor_is_known(i,j)) then write (u, *) i, j, color_table%factor(i,j) end if end do end do end if end subroutine color_table_write @ %def color_table_write @ This subroutine sets color factors, based on information from the hard matrix element: the list of pairs of color-flow indices (in the basis of the matrix element code), the list of corresponding factors, and the list of mappings from the matrix element index in the input interaction to the color-flow index in the hard matrix element object. We first determine the mapping of color-flow indices from the hard matrix element code to the current color table. The mapping could be nontrivial because the latter is derived from iterating over a state matrix, which may return states in non-canonical order. The translation table can be determined because we have, for the complete state matrix, both the mapping to the hard interaction (the input [[col_index_hi]]) and the mapping to the current color table (the component [[color_table%index]]). Once this mapping is known, we scan the list of index pairs [[color_flow_index]] and translate them to valid color-table index pairs. For this pair, the color factor is set using the corresponding entry in the list [[col_factor]]. <>= subroutine color_table_set_color_factors (color_table, & col_flow_index, col_factor, col_index_hi) type(color_table_t), intent(inout) :: color_table integer, dimension(:,:), intent(in) :: col_flow_index complex(default), dimension(:), intent(in) :: col_factor integer, dimension(:), intent(in) :: col_index_hi integer, dimension(:), allocatable :: hi_to_ct integer :: n_cflow integer :: hi_index, me_index, ct_index, cf_index integer, dimension(2) :: hi_index_pair, ct_index_pair n_cflow = size (col_index_hi) if (size (color_table%index) /= n_cflow) & call msg_bug ("Mismatch between hard matrix element and color table") allocate (hi_to_ct (n_cflow)) do me_index = 1, size (color_table%index) ct_index = color_table%index(me_index) hi_index = col_index_hi(me_index) hi_to_ct(hi_index) = ct_index end do do cf_index = 1, size (col_flow_index, 2) hi_index_pair = col_flow_index(:,cf_index) ct_index_pair = hi_to_ct(hi_index_pair) color_table%factor(ct_index_pair(1), ct_index_pair(2)) = & col_factor(cf_index) color_table%factor_is_known(ct_index_pair(1), ct_index_pair(2)) = .true. end do end subroutine color_table_set_color_factors @ %def color_table_set_color_factors @ This function returns a color factor, given two indices which point to the matrix elements of the initial state matrix. Internally, we can map them to the corresponding indices in the color table. As a side effect, we store the color factor in the color table for later lookup. (I.e., this function is impure.) <>= function color_table_get_color_factor (color_table, index1, index2, nc) & result (factor) real(default) :: factor type(color_table_t), intent(inout) :: color_table integer, intent(in) :: index1, index2 integer, intent(in), optional :: nc integer :: i1, i2 i1 = color_table%index(index1) i2 = color_table%index(index2) if (color_table%factor_is_known(i1,i2)) then factor = real(color_table%factor(i1,i2), kind=default) else factor = compute_color_factor & (color_table%col(:,i1), color_table%col(:,i2), nc) color_table%factor(i1,i2) = factor color_table%factor_is_known(i1,i2) = .true. end if end function color_table_get_color_factor @ %def color_table_get_color_factor @ \subsection{Creating an evaluator: Matrix multiplication} The evaluator for matrix multiplication is the most complicated variant. The initializer takes two input interactions and constructs the result evaluator, which consists of the interaction and the multiplication table for the product (or convolution) of the two. Normally, the input interactions are connected by one or more common particles (e.g., decay, structure function convolution). In the result interaction, quantum numbers of the connections can be summed over. This is determined by the [[qn_mask_conn]] argument. The [[qn_mask_rest]] argument is its analog for the other particles within the result interaction. (E.g., for the trace of the state matrix, all quantum numbers are summed over.) Finally, the [[connections_are_resonant]] argument tells whether the connecting particles should be marked as resonant in the final event record. This is useful for decays. The algorithm consists of the following steps: \begin{enumerate} \item [[find_connections]]: Find the particles which are connected, i.e., common to both input interactions. Either they are directly linked, or both are linked to a common source. \item [[compute_index_bounds_and_mappings]]: Compute the mappings of particle indices from the input interactions to the result interaction. There is a separate mapping for the connected particles. \item [[accumulate_connected_states]]: Create an auxiliary state matrix which lists the possible quantum numbers for the connected particles. When building this matrix, count the number of times each assignment is contained in any of the input states and, for each of the input states, record the index of the matrix element within the new state matrix. For the connected particles, reassign color indices such that no color state is present twice in different color-index assignment. Note that helicity assignments of the connected state can be (and will be) off-diagonal, so no spin correlations are lost in decays. Do this for both input interactions. \item [[allocate_connection_entries]]: Allocate a table of connections. Each table row corresponds to one state in the auxiliary matrix, and to multiple states of the input interactions. It collects all states of the unconnected particles in the two input interactions that are associated with the particular state (quantum-number assignment) of the connected particles. \item [[fill_connection_table]]: Fill the table of connections by scanning both input interactions. When copying states, reassign color indices for the unconnected particles such that they match between all involved particle sets (interaction 1, interaction 2, and connected particles). \item [[make_product_interaction]]: Scan the table of connections we have just built. For each entry, construct all possible pairs of states of the unconnected particles and combine them with the specific connected-particle state. This is a possible quantum-number assignment of the result interaction. Now mask all quantum numbers that should be summed over, and append this to the result state matrix. Record the matrix element index of the result. We now have the result interaction. \item [[make_pairing_array]]: First allocate the pairing array with the number of entries of the result interaction. Then scan the table of connections again. For each entry, record the indices of the matrix elements which have to be multiplied and summed over in order to compute this particular matrix element. This makes up the multiplication table. \item [[record_links]]: Transfer all source pointers from the input interactions to the result interaction. Do the same for the internal parent-child relations and resonance assignments. For the connected particles, make up appropriate additional parent-child relations. This allows for fetching momenta from other interactions when a new event is filled, and to reconstruct the event history when the event is analyzed. \end{enumerate} After all this is done, for each event, we just have to evaluate the pairing arrays (multiplication tables) in order to compute the result matrix elements in their proper positions. The quantum-number assignments remain fixed from now on. <>= procedure :: init_product => evaluator_init_product <>= subroutine evaluator_init_product & (eval, int_in1, int_in2, qn_mask_conn, qn_filter_conn, qn_mask_rest, & connections_are_resonant, ignore_sub_for_qn) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int_in1, int_in2 type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest logical, intent(in), optional :: connections_are_resonant logical, intent(in), optional :: ignore_sub_for_qn type(qn_mask_array_t), dimension(2) :: qn_mask_in type(state_matrix_t), pointer :: state_in1, state_in2 type :: connection_table_t integer :: n_conn = 0 integer, dimension(2) :: n_rest = 0 integer :: n_tot = 0 integer :: n_me_conn = 0 type(state_matrix_t) :: state type(index_map_t), dimension(:), allocatable :: index_conn type(connection_entry_t), dimension(:), allocatable :: entry type(index_map_t) :: index_result end type connection_table_t type(connection_table_t) :: connection_table integer :: n_in, n_vir, n_out, n_tot integer, dimension(2) :: n_rest integer :: n_conn integer, dimension(:,:), allocatable :: connection_index type(index_map_t), dimension(2) :: prt_map_in type(index_map_t) :: prt_map_conn type(prt_mask_t), dimension(2) :: prt_is_connected type(quantum_numbers_mask_t), dimension(:), allocatable :: & qn_mask_conn_initial, int_in1_mask, int_in2_mask integer :: i eval%type = EVAL_PRODUCT eval%int_in1 => int_in1 eval%int_in2 => int_in2 state_in1 => int_in1%get_state_matrix_ptr () state_in2 => int_in2%get_state_matrix_ptr () call find_connections (int_in1, int_in2, n_conn, connection_index) if (n_conn == 0) then call msg_message ("First interaction:") call int_in1%basic_write (col_verbose=.true.) call msg_message ("Second interaction:") call int_in2%basic_write (col_verbose=.true.) call msg_fatal ("Evaluator product: no connections found between factors") end if call compute_index_bounds_and_mappings & (int_in1, int_in2, n_conn, & n_in, n_vir, n_out, n_tot, & n_rest, prt_map_in, prt_map_conn) call prt_mask_init (prt_is_connected(1), int_in1%get_n_tot ()) call prt_mask_init (prt_is_connected(2), int_in2%get_n_tot ()) do i = 1, 2 prt_is_connected(i)%entry = .true. prt_is_connected(i)%entry(connection_index(:,i)) = .false. end do allocate (qn_mask_conn_initial (n_conn), & int_in1_mask (n_conn), int_in2_mask (n_conn)) int_in1_mask = int_in1%get_mask (connection_index(:,1)) int_in2_mask = int_in2%get_mask (connection_index(:,2)) do i = 1, n_conn qn_mask_conn_initial(i) = int_in1_mask(i) .or. int_in2_mask(i) end do allocate (qn_mask_in(1)%mask (int_in1%get_n_tot ())) allocate (qn_mask_in(2)%mask (int_in2%get_n_tot ())) qn_mask_in(1)%mask = int_in1%get_mask () qn_mask_in(2)%mask = int_in2%get_mask () call connection_table_init (connection_table, & state_in1, state_in2, & qn_mask_conn_initial, & n_conn, connection_index, n_rest, & qn_filter_conn, ignore_sub_for_qn) call connection_table_fill (connection_table, & state_in1, state_in2, & connection_index, prt_is_connected) call make_product_interaction (eval%interaction_t, & n_in, n_vir, n_out, & connection_table, & prt_map_in, prt_is_connected, & qn_mask_in, qn_mask_conn_initial, & qn_mask_conn, qn_filter_conn, qn_mask_rest) call make_pairing_array (eval%pairing_array, & eval%get_n_matrix_elements (), & connection_table) call record_links (eval%interaction_t, & int_in1, int_in2, connection_index, prt_map_in, prt_map_conn, & prt_is_connected, connections_are_resonant) call connection_table_final (connection_table) if (eval%get_n_matrix_elements () == 0) then print *, "Evaluator product" print *, "First interaction" call int_in1%basic_write (col_verbose=.true.) print * print *, "Second interaction" call int_in2%basic_write (col_verbose=.true.) print * call msg_fatal ("Product of density matrices is empty", & [var_str (" --------------------------------------------"), & var_str ("This happens when two density matrices are convoluted "), & var_str ("but the processes they belong to (e.g., production "), & var_str ("and decay) do not match. This could happen if the "), & var_str ("beam specification does not match the hard "), & var_str ("process. Or it may indicate a WHIZARD bug.")]) end if contains subroutine compute_index_bounds_and_mappings & (int1, int2, n_conn, & n_in, n_vir, n_out, n_tot, & n_rest, prt_map_in, prt_map_conn) class(interaction_t), intent(in) :: int1, int2 integer, intent(in) :: n_conn integer, intent(out) :: n_in, n_vir, n_out, n_tot integer, dimension(2), intent(out) :: n_rest type(index_map_t), dimension(2), intent(out) :: prt_map_in type(index_map_t), intent(out) :: prt_map_conn integer, dimension(:), allocatable :: index integer :: n_in1, n_vir1, n_out1 integer :: n_in2, n_vir2, n_out2 integer :: k n_in1 = int1%get_n_in () n_vir1 = int1%get_n_vir () n_out1 = int1%get_n_out () - n_conn n_rest(1) = n_in1 + n_vir1 + n_out1 n_in2 = int2%get_n_in () - n_conn n_vir2 = int2%get_n_vir () n_out2 = int2%get_n_out () n_rest(2) = n_in2 + n_vir2 + n_out2 n_in = n_in1 + n_in2 n_vir = n_vir1 + n_vir2 + n_conn n_out = n_out1 + n_out2 n_tot = n_in + n_vir + n_out call index_map_init (prt_map_in, n_rest) call index_map_init (prt_map_conn, n_conn) allocate (index (n_tot)) index = [ (i, i = 1, n_tot) ] prt_map_in(1)%entry(1 : n_in1) = index( 1 : n_in1) k = n_in1 prt_map_in(2)%entry(1 : n_in2) = index(k + 1 : k + n_in2) k = k + n_in2 prt_map_in(1)%entry(n_in1 + 1 : n_in1 + n_vir1) = index(k + 1 : k + n_vir1) k = k + n_vir1 prt_map_in(2)%entry(n_in2 + 1 : n_in2 + n_vir2) = index(k + 1 : k + n_vir2) k = k + n_vir2 prt_map_conn%entry = index(k + 1 : k + n_conn) k = k + n_conn prt_map_in(1)%entry(n_in1 + n_vir1 + 1 : n_rest(1)) = index(k + 1 : k + n_out1) k = k + n_out1 prt_map_in(2)%entry(n_in2 + n_vir2 + 1 : n_rest(2)) = index(k + 1 : k + n_out2) end subroutine compute_index_bounds_and_mappings subroutine connection_table_init & (connection_table, state_in1, state_in2, qn_mask_conn, & n_conn, connection_index, n_rest, & qn_filter_conn, ignore_sub_for_qn_in) type(connection_table_t), intent(out) :: connection_table type(state_matrix_t), intent(in), target :: state_in1, state_in2 type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_conn integer, intent(in) :: n_conn integer, dimension(:,:), intent(in) :: connection_index integer, dimension(2), intent(in) :: n_rest type(quantum_numbers_t), intent(in), optional :: qn_filter_conn logical, intent(in), optional :: ignore_sub_for_qn_in integer, dimension(2) :: n_me_in type(state_iterator_t) :: it type(quantum_numbers_t), dimension(n_conn) :: qn integer :: i, me_index_in, me_index_conn, n_me_conn integer, dimension(2) :: me_count logical :: ignore_sub_for_qn, has_sub_qn integer :: i_beam_sub connection_table%n_conn = n_conn connection_table%n_rest = n_rest n_me_in(1) = state_in1%get_n_matrix_elements () n_me_in(2) = state_in2%get_n_matrix_elements () allocate (connection_table%index_conn (2)) call index_map_init (connection_table%index_conn, n_me_in) connection_table%index_conn = 0 call connection_table%state%init (n_counters = 2) do i = 1, 2 select case (i) case (1); call it%init (state_in1) case (2); call it%init (state_in2) end select do while (it%is_valid ()) qn = it%get_quantum_numbers (connection_index(:,i)) call qn%undefine (qn_mask_conn) if (present (qn_filter_conn)) then if (.not. all (qn .match. qn_filter_conn)) then call it%advance (); cycle end if end if call quantum_numbers_canonicalize_color (qn) me_index_in = it%get_me_index () ignore_sub_for_qn = .false.; if (present (ignore_sub_for_qn_in)) ignore_sub_for_qn = ignore_sub_for_qn_in has_sub_qn = .false. do i_beam_sub = 1, n_beams_rescaled has_sub_qn = has_sub_qn .or. any (qn%get_sub () == i_beam_sub) end do call connection_table%state%add_state (qn, & counter_index = i, & ignore_sub_for_qn = .not. (ignore_sub_for_qn .and. has_sub_qn), & me_index = me_index_conn) call index_map_set_entry (connection_table%index_conn(i), & me_index_in, me_index_conn) call it%advance () end do end do n_me_conn = connection_table%state%get_n_matrix_elements () connection_table%n_me_conn = n_me_conn allocate (connection_table%entry (n_me_conn)) call it%init (connection_table%state) do while (it%is_valid ()) i = it%get_me_index () me_count = it%get_me_count () call connection_entry_init (connection_table%entry(i), 2, 2, & it%get_quantum_numbers (), me_count, n_rest) call it%advance () end do end subroutine connection_table_init subroutine connection_table_final (connection_table) type(connection_table_t), intent(inout) :: connection_table call connection_table%state%final () end subroutine connection_table_final subroutine connection_table_write (connection_table, unit) type(connection_table_t), intent(in) :: connection_table integer, intent(in), optional :: unit integer :: i, j integer :: u u = given_output_unit (unit) write (u, *) "Connection table:" call connection_table%state%write (unit) if (allocated (connection_table%index_conn)) then write (u, *) " Index mapping input => connection table:" do i = 1, size (connection_table%index_conn) write (u, *) " Input state", i do j = 1, size (connection_table%index_conn(i)) write (u, *) j, & index_map_get_entry (connection_table%index_conn(i), j) end do end do end if if (allocated (connection_table%entry)) then write (u, *) " Connection table contents:" do i = 1, size (connection_table%entry) call connection_entry_write (connection_table%entry(i), unit) end do end if if (index_map_exists (connection_table%index_result)) then write (u, *) " Index mapping connection table => output:" do i = 1, size (connection_table%index_result) write (u, *) i, & index_map_get_entry (connection_table%index_result, i) end do end if end subroutine connection_table_write subroutine connection_table_fill & (connection_table, state_in1, state_in2, & connection_index, prt_is_connected) type(connection_table_t), intent(inout) :: connection_table type(state_matrix_t), intent(in), target :: state_in1, state_in2 integer, dimension(:,:), intent(in) :: connection_index type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected type(state_iterator_t) :: it integer :: index_in, index_conn integer :: color_offset integer :: n_result_entries integer :: i, k color_offset = connection_table%state%get_max_color_value () do i = 1, 2 select case (i) case (1); call it%init (state_in1) case (2); call it%init (state_in2) end select do while (it%is_valid ()) index_in = it%get_me_index () index_conn = index_map_get_entry & (connection_table%index_conn(i), index_in) if (index_conn /= 0) then call connection_entry_add_state & (connection_table%entry(index_conn), i, & index_in, it%get_quantum_numbers (), & connection_index(:,i), prt_is_connected(i), & color_offset) end if call it%advance () end do color_offset = color_offset + state_in1%get_max_color_value () end do n_result_entries = 0 do k = 1, size (connection_table%entry) n_result_entries = & n_result_entries + product (connection_table%entry(k)%n_index) end do call index_map_init (connection_table%index_result, n_result_entries) end subroutine connection_table_fill subroutine connection_entry_add_state & (entry, i, index_in, qn_in, connection_index, prt_is_connected, & color_offset) type(connection_entry_t), intent(inout) :: entry integer, intent(in) :: i integer, intent(in) :: index_in type(quantum_numbers_t), dimension(:), intent(in) :: qn_in integer, dimension(:), intent(in) :: connection_index type(prt_mask_t), intent(in) :: prt_is_connected integer, intent(in) :: color_offset integer :: c integer, dimension(:,:), allocatable :: color_map entry%count(i) = entry%count(i) + 1 c = entry%count(i) call make_color_map (color_map, & qn_in(connection_index), entry%qn_conn) call index_map_set_entry (entry%index_in(i), c, index_in) entry%qn_in_list(i)%qn(:,c) = pack (qn_in, prt_is_connected%entry) call quantum_numbers_translate_color & (entry%qn_in_list(i)%qn(:,c), color_map, color_offset) end subroutine connection_entry_add_state subroutine make_product_interaction (int, & n_in, n_vir, n_out, & connection_table, & prt_map_in, prt_is_connected, & qn_mask_in, qn_mask_conn_initial, & qn_mask_conn, qn_filter_conn, qn_mask_rest) type(interaction_t), intent(out), target :: int integer, intent(in) :: n_in, n_vir, n_out type(connection_table_t), intent(inout), target :: connection_table type(index_map_t), dimension(2), intent(in) :: prt_map_in type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected type(qn_mask_array_t), dimension(2), intent(in) :: qn_mask_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: & qn_mask_conn_initial type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest type(index_map_t), dimension(2) :: prt_index_in type(index_map_t) :: prt_index_conn integer :: n_tot, n_conn integer, dimension(2) :: n_rest integer :: i, j, k, m type(quantum_numbers_t), dimension(:), allocatable :: qn type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(connection_entry_t), pointer :: entry integer :: result_index n_conn = connection_table%n_conn n_rest = connection_table%n_rest n_tot = sum (n_rest) + n_conn allocate (qn (n_tot), qn_mask (n_tot)) do i = 1, 2 call index_map_init (prt_index_in(i), n_rest(i)) prt_index_in(i) = & prt_map_in(i)%entry ([ (j, j = 1, n_rest(i)) ]) end do call index_map_init (prt_index_conn, n_conn) prt_index_conn = prt_map_conn%entry ([ (j, j = 1, n_conn) ]) do i = 1, 2 if (present (qn_mask_rest)) then qn_mask(prt_index_in(i)%entry) = & pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) & .or. qn_mask_rest else qn_mask(prt_index_in(i)%entry) = & pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) end if end do qn_mask(prt_index_conn%entry) = qn_mask_conn_initial .or. qn_mask_conn call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask = qn_mask) m = 1 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) qn(prt_index_conn%entry) = & quantum_numbers_undefined (entry%qn_conn, qn_mask_conn) if (present (qn_filter_conn)) then if (.not. all (qn(prt_index_conn%entry) .match. qn_filter_conn)) & cycle end if do j = 1, entry%n_index(1) qn(prt_index_in(1)%entry) = entry%qn_in_list(1)%qn(:,j) do k = 1, entry%n_index(2) qn(prt_index_in(2)%entry) = entry%qn_in_list(2)%qn(:,k) call int%add_state (qn, me_index = result_index) call index_map_set_entry & (connection_table%index_result, m, result_index) m = m + 1 end do end do end do call int%freeze () end subroutine make_product_interaction subroutine make_pairing_array (pa, n_matrix_elements, connection_table) type(pairing_array_t), dimension(:), intent(out), allocatable :: pa integer, intent(in) :: n_matrix_elements type(connection_table_t), intent(in), target :: connection_table type(connection_entry_t), pointer :: entry integer, dimension(:), allocatable :: n_entries integer :: i, j, k, m, r allocate (pa (n_matrix_elements)) allocate (n_entries (n_matrix_elements)) n_entries = 0 do m = 1, size (connection_table%index_result) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 end do call pairing_array_init & (pa, n_entries, has_i2=.true., has_factor=.false.) m = 1 n_entries = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) do j = 1, entry%n_index(1) do k = 1, entry%n_index(2) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 pa(r)%i1(n_entries(r)) = & index_map_get_entry (entry%index_in(1), j) pa(r)%i2(n_entries(r)) = & index_map_get_entry (entry%index_in(2), k) m = m + 1 end do end do end do end subroutine make_pairing_array subroutine record_links (int, & int_in1, int_in2, connection_index, prt_map_in, prt_map_conn, & prt_is_connected, connections_are_resonant) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in), target :: int_in1, int_in2 integer, dimension(:,:), intent(in) :: connection_index type(index_map_t), dimension(2), intent(in) :: prt_map_in type(index_map_t), intent(in) :: prt_map_conn type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected logical, intent(in), optional :: connections_are_resonant type(index_map_t), dimension(2) :: prt_map_all integer :: i, j, k, ival call index_map_init (prt_map_all(1), size (prt_is_connected(1))) k = 0 j = 0 do i = 1, size (prt_is_connected(1)) if (prt_is_connected(1)%entry(i)) then j = j + 1 ival = index_map_get_entry (prt_map_in(1), j) call index_map_set_entry (prt_map_all(1), i, ival) else k = k + 1 ival = index_map_get_entry (prt_map_conn, k) call index_map_set_entry (prt_map_all(1), i, ival) end if call int%set_source_link (ival, int_in1, i) end do call int_in1%transfer_relations (int, prt_map_all(1)%entry) call index_map_init (prt_map_all(2), size (prt_is_connected(2))) j = 0 do i = 1, size (prt_is_connected(2)) if (prt_is_connected(2)%entry(i)) then j = j + 1 ival = index_map_get_entry (prt_map_in(2), j) call index_map_set_entry (prt_map_all(2), i, ival) call int%set_source_link (ival, int_in2, i) else call index_map_set_entry (prt_map_all(2), i, 0) end if end do call int_in2%transfer_relations (int, prt_map_all(2)%entry) call int%relate_connections & (int_in2, connection_index(:,2), prt_map_all(2)%entry, & prt_map_conn%entry, connections_are_resonant) end subroutine record_links end subroutine evaluator_init_product @ %def evaluator_init_product @ \subsection{Creating an evaluator: square} The generic initializer for an evaluator that squares a matrix element. Depending on the provided mask, we select the appropriate specific initializer for either diagonal or non-diagonal helicity density matrices. <>= procedure :: init_square => evaluator_init_square <>= subroutine evaluator_init_square (eval, int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, dimension(:,:), intent(in), optional :: col_flow_index complex(default), dimension(:), intent(in), optional :: col_factor integer, dimension(:), intent(in), optional :: col_index_hi logical, intent(in), optional :: expand_color_flows integer, intent(in), optional :: nc if (all (qn_mask%diagonal_helicity ())) then call eval%init_square_diag (int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) else call eval%init_square_nondiag (int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) end if end subroutine evaluator_init_square @ %def evaluator_init_square @ \subsubsection{Color-summed squared matrix (diagonal helicities)} The initializer for an evaluator that squares a matrix element, including color factors. The mask must be such that off-diagonal matrix elements are excluded. If [[color_flows]] is set, the evaluator keeps color-flow entries separate and drops all interfering color structures. The color factors are set to unity in this case. There is only one input interaction. The quantum-number mask is an array, one entry for each particle, so they can be treated individually. For academic purposes, we allow for the number of colors being different from three (but 3 is the default). The algorithm is analogous to multiplication, with a few notable differences: \begin{enumerate} \item The connected particles are known, the correspondence is one-to-one. All particles are connected, and the mapping of indices is trivial, which simplifies the following steps. \item [[accumulate_connected_states]]: The matrix of connected states encompasses all particles, but color indices are removed. However, ghost states are still kept separate from physical color states. No color-index reassignment is necessary. \item The table of connections contains single index and quantum-number arrays instead of pairs of them. They are paired with themselves in all possible ways. \item [[make_squared_interaction]]: Now apply the predefined quantum-numbers mask, which usually collects all color states (physical and ghosts), and possibly a helicity sum. \item [[make_pairing_array]]: For each pair of input states, compute the color factor (including a potential ghost-parity sign) and store this in the pairing array together with the matrix-element indices for multiplication. \item [[record_links]]: This is again trivial due to the one-to-one correspondence. \end{enumerate} <>= procedure :: init_square_diag => evaluator_init_square_diag <>= subroutine evaluator_init_square_diag (eval, int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, dimension(:,:), intent(in), optional :: col_flow_index complex(default), dimension(:), intent(in), optional :: col_factor integer, dimension(:), intent(in), optional :: col_index_hi logical, intent(in), optional :: expand_color_flows integer, intent(in), optional :: nc integer :: n_in, n_vir, n_out, n_tot type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_initial type(state_matrix_t), pointer :: state_in type :: connection_table_t integer :: n_tot = 0 integer :: n_me_conn = 0 type(state_matrix_t) :: state type(index_map_t) :: index_conn type(connection_entry_t), dimension(:), allocatable :: entry type(index_map_t) :: index_result end type connection_table_t type(connection_table_t) :: connection_table logical :: sum_colors type(color_table_t) :: color_table if (present (expand_color_flows)) then sum_colors = .not. expand_color_flows else sum_colors = .true. end if if (sum_colors) then eval%type = EVAL_SQUARE_WITH_COLOR_FACTORS else eval%type = EVAL_SQUARED_FLOWS end if eval%int_in1 => int_in n_in = int_in%get_n_in () n_vir = int_in%get_n_vir () n_out = int_in%get_n_out () n_tot = int_in%get_n_tot () state_in => int_in%get_state_matrix_ptr () allocate (qn_mask_initial (n_tot)) qn_mask_initial = int_in%get_mask () call qn_mask_initial%set_color (sum_colors, mask_cg=.false.) if (sum_colors) then call color_table_init (color_table, state_in, n_tot) if (present (col_flow_index) .and. present (col_factor) & .and. present (col_index_hi)) then call color_table_set_color_factors & (color_table, col_flow_index, col_factor, col_index_hi) end if end if call connection_table_init (connection_table, state_in, & qn_mask_initial, qn_mask, n_tot) call connection_table_fill (connection_table, state_in) call make_squared_interaction (eval%interaction_t, & n_in, n_vir, n_out, n_tot, & connection_table, sum_colors, qn_mask_initial .or. qn_mask) call make_pairing_array (eval%pairing_array, & eval%get_n_matrix_elements (), & connection_table, sum_colors, color_table, n_in, n_tot, nc) call record_links (eval, int_in, n_tot) call connection_table_final (connection_table) contains subroutine connection_table_init & (connection_table, state_in, qn_mask_in, qn_mask, n_tot) type(connection_table_t), intent(out) :: connection_table type(state_matrix_t), intent(in), target :: state_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, intent(in) :: n_tot type(quantum_numbers_t), dimension(n_tot) :: qn type(state_iterator_t) :: it integer :: i, n_me_in, me_index_in integer :: me_index_conn, n_me_conn integer, dimension(1) :: me_count logical :: qn_passed connection_table%n_tot = n_tot n_me_in = state_in%get_n_matrix_elements () call index_map_init (connection_table%index_conn, n_me_in) connection_table%index_conn = 0 call connection_table%state%init (n_counters=1) call it%init (state_in) do while (it%is_valid ()) qn = it%get_quantum_numbers () if (all (quantum_numbers_are_physical (qn, qn_mask))) then call qn%undefine (qn_mask_in) qn_passed = .true. if (qn_passed) then me_index_in = it%get_me_index () call connection_table%state%add_state (qn, & counter_index = 1, me_index = me_index_conn) call index_map_set_entry (connection_table%index_conn, & me_index_in, me_index_conn) end if end if call it%advance () end do n_me_conn = connection_table%state%get_n_matrix_elements () connection_table%n_me_conn = n_me_conn allocate (connection_table%entry (n_me_conn)) call it%init (connection_table%state) do while (it%is_valid ()) i = it%get_me_index () me_count = it%get_me_count () call connection_entry_init (connection_table%entry(i), 1, 2, & it%get_quantum_numbers (), me_count, [n_tot]) call it%advance () end do end subroutine connection_table_init subroutine connection_table_final (connection_table) type(connection_table_t), intent(inout) :: connection_table call connection_table%state%final () end subroutine connection_table_final subroutine connection_table_write (connection_table, unit) type(connection_table_t), intent(in) :: connection_table integer, intent(in), optional :: unit integer :: i integer :: u u = given_output_unit (unit) write (u, *) "Connection table:" call connection_table%state%write (unit) if (index_map_exists (connection_table%index_conn)) then write (u, *) " Index mapping input => connection table:" do i = 1, size (connection_table%index_conn) write (u, *) i, & index_map_get_entry (connection_table%index_conn, i) end do end if if (allocated (connection_table%entry)) then write (u, *) " Connection table contents" do i = 1, size (connection_table%entry) call connection_entry_write (connection_table%entry(i), unit) end do end if if (index_map_exists (connection_table%index_result)) then write (u, *) " Index mapping connection table => output" do i = 1, size (connection_table%index_result) write (u, *) i, & index_map_get_entry (connection_table%index_result, i) end do end if end subroutine connection_table_write subroutine connection_table_fill (connection_table, state) type(connection_table_t), intent(inout) :: connection_table type(state_matrix_t), intent(in), target :: state integer :: index_in, index_conn, n_result_entries type(state_iterator_t) :: it integer :: k call it%init (state) do while (it%is_valid ()) index_in = it%get_me_index () index_conn = & index_map_get_entry (connection_table%index_conn, index_in) if (index_conn /= 0) then call connection_entry_add_state & (connection_table%entry(index_conn), & index_in, it%get_quantum_numbers ()) end if call it%advance () end do n_result_entries = 0 do k = 1, size (connection_table%entry) n_result_entries = & n_result_entries + connection_table%entry(k)%n_index(1) ** 2 end do call index_map_init (connection_table%index_result, n_result_entries) connection_table%index_result = 0 end subroutine connection_table_fill subroutine connection_entry_add_state (entry, index_in, qn_in) type(connection_entry_t), intent(inout) :: entry integer, intent(in) :: index_in type(quantum_numbers_t), dimension(:), intent(in) :: qn_in integer :: c entry%count = entry%count + 1 c = entry%count(1) call index_map_set_entry (entry%index_in(1), c, index_in) entry%qn_in_list(1)%qn(:,c) = qn_in end subroutine connection_entry_add_state subroutine make_squared_interaction (int, & n_in, n_vir, n_out, n_tot, & connection_table, sum_colors, qn_mask) type(interaction_t), intent(out), target :: int integer, intent(in) :: n_in, n_vir, n_out, n_tot type(connection_table_t), intent(inout), target :: connection_table logical, intent(in) :: sum_colors type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask type(connection_entry_t), pointer :: entry integer :: result_index, n_contrib integer :: i, m type(quantum_numbers_t), dimension(n_tot) :: qn call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask=qn_mask) m = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) qn = quantum_numbers_undefined (entry%qn_conn, qn_mask) if (.not. sum_colors) call qn(1:n_in)%invert_color () call int%add_state (qn, me_index = result_index) n_contrib = entry%n_index(1) ** 2 connection_table%index_result%entry(m+1:m+n_contrib) = result_index m = m + n_contrib end do call int%freeze () end subroutine make_squared_interaction subroutine make_pairing_array (pa, & n_matrix_elements, connection_table, sum_colors, color_table, & n_in, n_tot, nc) type(pairing_array_t), dimension(:), intent(out), allocatable :: pa integer, intent(in) :: n_matrix_elements type(connection_table_t), intent(in), target :: connection_table logical, intent(in) :: sum_colors type(color_table_t), intent(inout) :: color_table type(connection_entry_t), pointer :: entry integer, intent(in) :: n_in, n_tot integer, intent(in), optional :: nc integer, dimension(:), allocatable :: n_entries integer :: i, k, l, ks, ls, m, r integer :: color_multiplicity_in allocate (pa (n_matrix_elements)) allocate (n_entries (n_matrix_elements)) n_entries = 0 do m = 1, size (connection_table%index_result) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 end do call pairing_array_init & (pa, n_entries, has_i2 = sum_colors, has_factor = sum_colors) m = 1 n_entries = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) do k = 1, entry%n_index(1) if (sum_colors) then color_multiplicity_in = product (abs & (entry%qn_in_list(1)%qn(:n_in, k)%get_color_type ())) do l = 1, entry%n_index(1) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 ks = index_map_get_entry (entry%index_in(1), k) ls = index_map_get_entry (entry%index_in(1), l) pa(r)%i1(n_entries(r)) = ks pa(r)%i2(n_entries(r)) = ls pa(r)%factor(n_entries(r)) = & color_table_get_color_factor (color_table, ks, ls, nc) & / color_multiplicity_in m = m + 1 end do else r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 ks = index_map_get_entry (entry%index_in(1), k) pa(r)%i1(n_entries(r)) = ks m = m + 1 end if end do end do end subroutine make_pairing_array subroutine record_links (int, int_in, n_tot) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in), target :: int_in integer, intent(in) :: n_tot integer, dimension(n_tot) :: map integer :: i do i = 1, n_tot call int%set_source_link (i, int_in, i) end do map = [ (i, i = 1, n_tot) ] call int_in%transfer_relations (int, map) end subroutine record_links end subroutine evaluator_init_square_diag @ %def evaluator_init_square_diag @ \subsubsection{Color-summed squared matrix (support nodiagonal helicities)} The initializer for an evaluator that squares a matrix element, including color factors. Unless requested otherwise by the quantum-number mask, the result contains off-diagonal matrix elements. (The input interaction must be diagonal since it represents an amplitude, not a density matrix.) There is only one input interaction. The quantum-number mask is an array, one entry for each particle, so they can be treated individually. For academic purposes, we allow for the number of colors being different from three (but 3 is the default). The algorithm is analogous to the previous one, with some additional complications due to the necessity to loop over two helicity indices. <>= procedure :: init_square_nondiag => evaluator_init_square_nondiag <>= subroutine evaluator_init_square_nondiag (eval, int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, dimension(:,:), intent(in), optional :: col_flow_index complex(default), dimension(:), intent(in), optional :: col_factor integer, dimension(:), intent(in), optional :: col_index_hi logical, intent(in), optional :: expand_color_flows integer, intent(in), optional :: nc integer :: n_in, n_vir, n_out, n_tot type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_initial type(state_matrix_t), pointer :: state_in type :: connection_table_t integer :: n_tot = 0 integer :: n_me_conn = 0 type(state_matrix_t) :: state type(index_map2_t) :: index_conn type(connection_entry_t), dimension(:), allocatable :: entry type(index_map_t) :: index_result end type connection_table_t type(connection_table_t) :: connection_table logical :: sum_colors type(color_table_t) :: color_table if (present (expand_color_flows)) then sum_colors = .not. expand_color_flows else sum_colors = .true. end if if (sum_colors) then eval%type = EVAL_SQUARE_WITH_COLOR_FACTORS else eval%type = EVAL_SQUARED_FLOWS end if eval%int_in1 => int_in n_in = int_in%get_n_in () n_vir = int_in%get_n_vir () n_out = int_in%get_n_out () n_tot = int_in%get_n_tot () state_in => int_in%get_state_matrix_ptr () allocate (qn_mask_initial (n_tot)) qn_mask_initial = int_in%get_mask () call qn_mask_initial%set_color (sum_colors, mask_cg=.false.) if (sum_colors) then call color_table_init (color_table, state_in, n_tot) if (present (col_flow_index) .and. present (col_factor) & .and. present (col_index_hi)) then call color_table_set_color_factors & (color_table, col_flow_index, col_factor, col_index_hi) end if end if call connection_table_init (connection_table, state_in, & qn_mask_initial, qn_mask, n_tot) call connection_table_fill (connection_table, state_in) call make_squared_interaction (eval%interaction_t, & n_in, n_vir, n_out, n_tot, & connection_table, sum_colors, qn_mask_initial .or. qn_mask) call make_pairing_array (eval%pairing_array, & eval%get_n_matrix_elements (), & connection_table, sum_colors, color_table, n_in, n_tot, nc) call record_links (eval, int_in, n_tot) call connection_table_final (connection_table) contains subroutine connection_table_init & (connection_table, state_in, qn_mask_in, qn_mask, n_tot) type(connection_table_t), intent(out) :: connection_table type(state_matrix_t), intent(in), target :: state_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, intent(in) :: n_tot type(quantum_numbers_t), dimension(n_tot) :: qn1, qn2, qn type(state_iterator_t) :: it1, it2, it integer :: i, n_me_in, me_index_in1, me_index_in2 integer :: me_index_conn, n_me_conn integer, dimension(1) :: me_count logical :: qn_passed connection_table%n_tot = n_tot n_me_in = state_in%get_n_matrix_elements () call index_map2_init (connection_table%index_conn, n_me_in) connection_table%index_conn = 0 call connection_table%state%init (n_counters=1) call it1%init (state_in) do while (it1%is_valid ()) qn1 = it1%get_quantum_numbers () me_index_in1 = it1%get_me_index () call it2%init (state_in) do while (it2%is_valid ()) qn2 = it2%get_quantum_numbers () if (all (quantum_numbers_are_compatible (qn1, qn2, qn_mask))) then qn = qn1 .merge. qn2 call qn%undefine (qn_mask_in) qn_passed = .true. if (qn_passed) then me_index_in2 = it2%get_me_index () call connection_table%state%add_state (qn, & counter_index = 1, me_index = me_index_conn) call index_map2_set_entry (connection_table%index_conn, & me_index_in1, me_index_in2, me_index_conn) end if end if call it2%advance () end do call it1%advance () end do n_me_conn = connection_table%state%get_n_matrix_elements () connection_table%n_me_conn = n_me_conn allocate (connection_table%entry (n_me_conn)) call it%init (connection_table%state) do while (it%is_valid ()) i = it%get_me_index () me_count = it%get_me_count () call connection_entry_init (connection_table%entry(i), 1, 2, & it%get_quantum_numbers (), me_count, [n_tot]) call it%advance () end do end subroutine connection_table_init subroutine connection_table_final (connection_table) type(connection_table_t), intent(inout) :: connection_table call connection_table%state%final () end subroutine connection_table_final subroutine connection_table_write (connection_table, unit) type(connection_table_t), intent(in) :: connection_table integer, intent(in), optional :: unit integer :: i, j integer :: u u = given_output_unit (unit) write (u, *) "Connection table:" call connection_table%state%write (unit) if (index_map2_exists (connection_table%index_conn)) then write (u, *) " Index mapping input => connection table:" do i = 1, size (connection_table%index_conn) do j = 1, size (connection_table%index_conn) write (u, *) i, j, & index_map2_get_entry (connection_table%index_conn, i, j) end do end do end if if (allocated (connection_table%entry)) then write (u, *) " Connection table contents" do i = 1, size (connection_table%entry) call connection_entry_write (connection_table%entry(i), unit) end do end if if (index_map_exists (connection_table%index_result)) then write (u, *) " Index mapping connection table => output" do i = 1, size (connection_table%index_result) write (u, *) i, & index_map_get_entry (connection_table%index_result, i) end do end if end subroutine connection_table_write subroutine connection_table_fill (connection_table, state) type(connection_table_t), intent(inout), target :: connection_table type(state_matrix_t), intent(in), target :: state integer :: index1_in, index2_in, index_conn, n_result_entries type(state_iterator_t) :: it1, it2 integer :: k call it1%init (state) do while (it1%is_valid ()) index1_in = it1%get_me_index () call it2%init (state) do while (it2%is_valid ()) index2_in = it2%get_me_index () index_conn = index_map2_get_entry & (connection_table%index_conn, index1_in, index2_in) if (index_conn /= 0) then call connection_entry_add_state & (connection_table%entry(index_conn), & index1_in, index2_in, & it1%get_quantum_numbers () & .merge. & it2%get_quantum_numbers ()) end if call it2%advance () end do call it1%advance () end do n_result_entries = 0 do k = 1, size (connection_table%entry) n_result_entries = & n_result_entries + connection_table%entry(k)%n_index(1) end do call index_map_init (connection_table%index_result, n_result_entries) connection_table%index_result = 0 end subroutine connection_table_fill subroutine connection_entry_add_state (entry, index1_in, index2_in, qn_in) type(connection_entry_t), intent(inout) :: entry integer, intent(in) :: index1_in, index2_in type(quantum_numbers_t), dimension(:), intent(in) :: qn_in integer :: c entry%count = entry%count + 1 c = entry%count(1) call index_map_set_entry (entry%index_in(1), c, index1_in) call index_map_set_entry (entry%index_in(2), c, index2_in) entry%qn_in_list(1)%qn(:,c) = qn_in end subroutine connection_entry_add_state subroutine make_squared_interaction (int, & n_in, n_vir, n_out, n_tot, & connection_table, sum_colors, qn_mask) type(interaction_t), intent(out), target :: int integer, intent(in) :: n_in, n_vir, n_out, n_tot type(connection_table_t), intent(inout), target :: connection_table logical, intent(in) :: sum_colors type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask type(connection_entry_t), pointer :: entry integer :: result_index integer :: i, k, m type(quantum_numbers_t), dimension(n_tot) :: qn call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask=qn_mask) m = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) do k = 1, size (entry%qn_in_list(1)%qn, 2) qn = quantum_numbers_undefined & (entry%qn_in_list(1)%qn(:,k), qn_mask) if (.not. sum_colors) call qn(1:n_in)%invert_color () call int%add_state (qn, me_index = result_index) call index_map_set_entry (connection_table%index_result, m + 1, & result_index) m = m + 1 end do end do call int%freeze () end subroutine make_squared_interaction subroutine make_pairing_array (pa, & n_matrix_elements, connection_table, sum_colors, color_table, & n_in, n_tot, nc) type(pairing_array_t), dimension(:), intent(out), allocatable :: pa integer, intent(in) :: n_matrix_elements type(connection_table_t), intent(in), target :: connection_table logical, intent(in) :: sum_colors type(color_table_t), intent(inout) :: color_table type(connection_entry_t), pointer :: entry integer, intent(in) :: n_in, n_tot integer, intent(in), optional :: nc integer, dimension(:), allocatable :: n_entries integer :: i, k, k1s, k2s, m, r integer :: color_multiplicity_in allocate (pa (n_matrix_elements)) allocate (n_entries (n_matrix_elements)) n_entries = 0 do m = 1, size (connection_table%index_result) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 end do call pairing_array_init & (pa, n_entries, has_i2 = sum_colors, has_factor = sum_colors) m = 1 n_entries = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) do k = 1, entry%n_index(1) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 if (sum_colors) then k1s = index_map_get_entry (entry%index_in(1), k) k2s = index_map_get_entry (entry%index_in(2), k) pa(r)%i1(n_entries(r)) = k1s pa(r)%i2(n_entries(r)) = k2s color_multiplicity_in = product (abs & (entry%qn_in_list(1)%qn(:n_in, k)%get_color_type ())) pa(r)%factor(n_entries(r)) = & color_table_get_color_factor (color_table, k1s, k2s, nc) & / color_multiplicity_in else k1s = index_map_get_entry (entry%index_in(1), k) pa(r)%i1(n_entries(r)) = k1s end if m = m + 1 end do end do end subroutine make_pairing_array subroutine record_links (int, int_in, n_tot) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in), target :: int_in integer, intent(in) :: n_tot integer, dimension(n_tot) :: map integer :: i do i = 1, n_tot call int%set_source_link (i, int_in, i) end do map = [ (i, i = 1, n_tot) ] call int_in%transfer_relations (int, map) end subroutine record_links end subroutine evaluator_init_square_nondiag @ %def evaluator_init_square_nondiag @ \subsubsection{Copy with additional contracted color states} This evaluator involves no square or multiplication, its matrix elements are just copies of the (single) input interaction. However, the state matrix of the interaction contains additional states that have color indices contracted. This is used for copies of the beam or structure-function interactions that need to match the hard interaction also in the case where its color indices coincide. <>= procedure :: init_color_contractions => evaluator_init_color_contractions <>= subroutine evaluator_init_color_contractions (eval, int_in) class(evaluator_t), intent(out), target :: eval type(interaction_t), intent(in), target :: int_in integer :: n_in, n_vir, n_out, n_tot type(state_matrix_t) :: state_with_contractions integer, dimension(:), allocatable :: me_index integer, dimension(:), allocatable :: result_index eval%type = EVAL_COLOR_CONTRACTION eval%int_in1 => int_in n_in = int_in%get_n_in () n_vir = int_in%get_n_vir () n_out = int_in%get_n_out () n_tot = int_in%get_n_tot () state_with_contractions = int_in%get_state_matrix_ptr () call state_with_contractions%add_color_contractions () call make_contracted_interaction (eval%interaction_t, & me_index, result_index, & n_in, n_vir, n_out, n_tot, & state_with_contractions, int_in%get_mask ()) call make_pairing_array (eval%pairing_array, me_index, result_index) call record_links (eval, int_in, n_tot) call state_with_contractions%final () contains subroutine make_contracted_interaction (int, & me_index, result_index, & n_in, n_vir, n_out, n_tot, state, qn_mask) type(interaction_t), intent(out), target :: int integer, dimension(:), intent(out), allocatable :: me_index integer, dimension(:), intent(out), allocatable :: result_index integer, intent(in) :: n_in, n_vir, n_out, n_tot type(state_matrix_t), intent(in) :: state type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask type(state_iterator_t) :: it integer :: n_me, i type(quantum_numbers_t), dimension(n_tot) :: qn call int%basic_init (n_in, n_vir, n_out, mask=qn_mask) n_me = state%get_n_leaves () allocate (me_index (n_me)) allocate (result_index (n_me)) call it%init (state) i = 0 do while (it%is_valid ()) i = i + 1 me_index(i) = it%get_me_index () qn = it%get_quantum_numbers () call int%add_state (qn, me_index = result_index(i)) call it%advance () end do call int%freeze () end subroutine make_contracted_interaction subroutine make_pairing_array (pa, me_index, result_index) type(pairing_array_t), dimension(:), intent(out), allocatable :: pa integer, dimension(:), intent(in) :: me_index, result_index integer, dimension(:), allocatable :: n_entries integer :: n_matrix_elements, r, i, k !!! The result indices of the appended color contracted states !!! start counting from 1 again. For the pairing array, we currently !!! only take the first part of ascending indices into account !!! excluding the color contracted states. n_matrix_elements = size (me_index) k = 0 do i = 1, n_matrix_elements r = result_index(i) if (r < i) exit k = r end do allocate (pa (k)) allocate (n_entries (k)) n_entries = 1 call pairing_array_init & (pa, n_entries, has_i2=.false., has_factor=.false.) do i = 1, k r = result_index(i) pa(r)%i1(1) = me_index(i) end do end subroutine make_pairing_array subroutine record_links (int, int_in, n_tot) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in), target :: int_in integer, intent(in) :: n_tot integer, dimension(n_tot) :: map integer :: i do i = 1, n_tot call int%set_source_link (i, int_in, i) end do map = [ (i, i = 1, n_tot) ] call int_in%transfer_relations (int, map) end subroutine record_links end subroutine evaluator_init_color_contractions @ %def evaluator_init_color_contractions @ \subsubsection{Auxiliary procedure for initialization} This will become a standard procedure in F2008. The result is true if the number of true values in the mask is odd. We use the function for determining the ghost parity of a quantum-number array. [tho:] It's not used anymore and [[mod (count (mask), 2) == 1]] is a cooler implementation anyway. <<(UNUSED) Evaluators: procedures>>= function parity (mask) logical :: parity logical, dimension(:) :: mask integer :: i parity = .false. do i = 1, size (mask) if (mask(i)) parity = .not. parity end do end function parity @ %def parity @ Reassign external source links from one to another. <>= public :: evaluator_reassign_links <>= interface evaluator_reassign_links module procedure evaluator_reassign_links_eval module procedure evaluator_reassign_links_int end interface <>= subroutine evaluator_reassign_links_eval (eval, eval_src, eval_target) type(evaluator_t), intent(inout) :: eval type(evaluator_t), intent(in) :: eval_src type(evaluator_t), intent(in), target :: eval_target if (associated (eval%int_in1)) then if (eval%int_in1%get_tag () == eval_src%get_tag ()) then eval%int_in1 => eval_target%interaction_t end if end if if (associated (eval%int_in2)) then if (eval%int_in2%get_tag () == eval_src%get_tag ()) then eval%int_in2 => eval_target%interaction_t end if end if call interaction_reassign_links & (eval%interaction_t, eval_src%interaction_t, & eval_target%interaction_t) end subroutine evaluator_reassign_links_eval subroutine evaluator_reassign_links_int (eval, int_src, int_target) type(evaluator_t), intent(inout) :: eval type(interaction_t), intent(in) :: int_src type(interaction_t), intent(in), target :: int_target if (associated (eval%int_in1)) then if (eval%int_in1%get_tag () == int_src%get_tag ()) then eval%int_in1 => int_target end if end if if (associated (eval%int_in2)) then if (eval%int_in2%get_tag () == int_src%get_tag ()) then eval%int_in2 => int_target end if end if call interaction_reassign_links (eval%interaction_t, int_src, int_target) end subroutine evaluator_reassign_links_int @ %def evaluator_reassign_links @ Return flavor, momentum, and position of the first unstable particle present in the interaction. <>= public :: evaluator_get_unstable_particle <>= subroutine evaluator_get_unstable_particle (eval, flv, p, i) type(evaluator_t), intent(in) :: eval type(flavor_t), intent(out) :: flv type(vector4_t), intent(out) :: p integer, intent(out) :: i call interaction_get_unstable_particle (eval%interaction_t, flv, p, i) end subroutine evaluator_get_unstable_particle @ %def evaluator_get_unstable_particle @ <>= public :: evaluator_get_int_in_ptr <>= function evaluator_get_int_in_ptr (eval, i) result (int_in) class(interaction_t), pointer :: int_in type(evaluator_t), intent(in), target :: eval integer, intent(in) :: i if (i == 1) then int_in => eval%int_in1 else if (i == 2) then int_in => eval%int_in2 else int_in => null () end if end function evaluator_get_int_in_ptr @ %def evaluator_get_int_in_ptr @ \subsection{Creating an evaluator: identity} The identity evaluator creates a copy of the first input evaluator; the second input is not used. All particles link back to the input evaluatorand the internal relations are copied. As evaluation does take a shortcut by cloning the matrix elements, the pairing array is not used and does not have to be set up. <>= procedure :: init_identity => evaluator_init_identity <>= subroutine evaluator_init_identity (eval, int) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int integer :: n_in, n_out, n_vir, n_tot integer :: i integer, dimension(:), allocatable :: map type(state_matrix_t), pointer :: state type(state_iterator_t) :: it eval%type = EVAL_IDENTITY eval%int_in1 => int nullify (eval%int_in2) n_in = int%get_n_in () n_out = int%get_n_out () n_vir = int%get_n_vir () n_tot = int%get_n_tot () call eval%interaction_t%basic_init (n_in, n_vir, n_out, & mask = int%get_mask (), & resonant = int%get_resonance_flags ()) do i = 1, n_tot call eval%set_source_link (i, int, i) end do allocate (map(n_tot)) map = [(i, i = 1, n_tot)] call int%transfer_relations (eval, map) state => int%get_state_matrix_ptr () call it%init (state) do while (it%is_valid ()) call eval%add_state (it%get_quantum_numbers (), & it%get_me_index ()) call it%advance () end do call eval%freeze () end subroutine evaluator_init_identity @ %def evaluator_init_identity @ \subsection {Creating an evaluator: quantum number sum} This evaluator operates on the diagonal of a density matrix and sums over the quantum numbers specified by the mask. The optional argument [[drop]] allows to drop a particle from the resulting density matrix. The handling of virtuals is not completely sane, especially in connection with dropping particles. When summing over matrix element entries, we keep the separation into entries and normalization (in the corresponding evaluation routine below). <>= procedure :: init_qn_sum => evaluator_init_qn_sum <>= subroutine evaluator_init_qn_sum (eval, int, qn_mask, drop) class(evaluator_t), intent(out), target :: eval class(interaction_t), target, intent(in) :: int type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask logical, intent(in), optional, dimension(:) :: drop type(state_iterator_t) :: it_old, it_new integer, dimension(:), allocatable :: pairing_size, pairing_target, i_new integer, dimension(:), allocatable :: map integer :: n_in, n_out, n_vir, n_tot, n_me_old, n_me_new integer :: i, j type(state_matrix_t), pointer :: state_new, state_old type(quantum_numbers_t), dimension(:), allocatable :: qn logical :: matched logical, dimension(size (qn_mask)) :: dropped integer :: ndropped integer, dimension(:), allocatable :: inotdropped type(quantum_numbers_mask_t), dimension(:), allocatable :: mask logical, dimension(:), allocatable :: resonant eval%type = EVAL_QN_SUM eval%int_in1 => int nullify (eval%int_in2) if (present (drop)) then dropped = drop else dropped = .false. end if ndropped = count (dropped) n_in = int%get_n_in () n_out = int%get_n_out () - ndropped n_vir = int%get_n_vir () n_tot = int%get_n_tot () - ndropped allocate (inotdropped (n_tot)) i = 1 do j = 1, n_tot + ndropped if (dropped (j)) cycle inotdropped(i) = j i = i + 1 end do allocate (mask(n_tot + ndropped)) mask = int%get_mask () allocate (resonant(n_tot + ndropped)) resonant = int%get_resonance_flags () call eval%interaction_t%basic_init (n_in, n_vir, n_out, & mask = mask(inotdropped) .or. qn_mask(inotdropped), & resonant = resonant(inotdropped)) i = 1 do j = 1, n_tot + ndropped if (dropped(j)) cycle call eval%set_source_link (i, int, j) i = i + 1 end do allocate (map(n_tot + ndropped)) i = 1 do j = 1, n_tot + ndropped if (dropped (j)) then map(j) = 0 else map(j) = i i = i + 1 end if end do call int%transfer_relations (eval, map) n_me_old = int%get_n_matrix_elements () allocate (pairing_size (n_me_old), source = 0) allocate (pairing_target (n_me_old), source = 0) pairing_size = 0 state_old => int%get_state_matrix_ptr () state_new => eval%get_state_matrix_ptr () call it_old%init (state_old) allocate (qn(n_tot + ndropped)) do while (it_old%is_valid ()) qn = it_old%get_quantum_numbers () if (.not. all (qn%are_diagonal ())) then call it_old%advance () cycle end if matched = .false. call it_new%init (state_new) if (eval%get_n_matrix_elements () > 0) then do while (it_new%is_valid ()) if (all (qn(inotdropped) .match. & it_new%get_quantum_numbers ())) & then matched = .true. i = it_new%get_me_index () exit end if call it_new%advance () end do end if if (.not. matched) then call eval%add_state (qn(inotdropped)) i = eval%get_n_matrix_elements () end if pairing_size(i) = pairing_size(i) + 1 pairing_target(it_old%get_me_index ()) = i call it_old%advance () end do call eval%freeze () n_me_new = eval%get_n_matrix_elements () allocate (eval%pairing_array (n_me_new)) do i = 1, n_me_new call pairing_array_init (eval%pairing_array(i), & pairing_size(i), .false., .false.) end do allocate (i_new (n_me_new), source = 0) do i = 1, n_me_old j = pairing_target(i) if (j > 0) then i_new(j) = i_new(j) + 1 eval%pairing_array(j)%i1(i_new(j)) = i end if end do end subroutine evaluator_init_qn_sum @ %def evaluator_init_qn_sum @ \subsection{Evaluation} When the input interactions (which are pointed to in the pairings stored within the evaluator) are filled with values, we can activate the evaluator, i.e., calculate the result values which are stored in the interaction. The evaluation of matrix elements can be done in parallel. A [[forall]] construct is not appropriate, however. We would need [[do concurrent]] here. Nevertheless, the evaluation functions are marked as [[pure]]. <>= procedure :: evaluate => evaluator_evaluate <>= subroutine evaluator_evaluate (eval) class(evaluator_t), intent(inout), target :: eval integer :: i select case (eval%type) case (EVAL_PRODUCT) do i = 1, size(eval%pairing_array) call eval%evaluate_product (i, & eval%int_in1, eval%int_in2, & eval%pairing_array(i)%i1, eval%pairing_array(i)%i2) if (debug2_active (D_QFT)) then print *, 'eval%pairing_array(i)%i1, eval%pairing_array(i)%i2 = ', & eval%pairing_array(i)%i1, eval%pairing_array(i)%i2 print *, 'MEs = ', & eval%int_in1%get_matrix_element (eval%pairing_array(i)%i1), & eval%int_in2%get_matrix_element (eval%pairing_array(i)%i2) end if end do case (EVAL_SQUARE_WITH_COLOR_FACTORS) do i = 1, size(eval%pairing_array) call eval%evaluate_product_cf (i, & eval%int_in1, eval%int_in1, & eval%pairing_array(i)%i1, eval%pairing_array(i)%i2, & eval%pairing_array(i)%factor) end do case (EVAL_SQUARED_FLOWS) do i = 1, size(eval%pairing_array) call eval%evaluate_square_c (i, & eval%int_in1, & eval%pairing_array(i)%i1) end do case (EVAL_COLOR_CONTRACTION) do i = 1, size(eval%pairing_array) call eval%evaluate_sum (i, & eval%int_in1, & eval%pairing_array(i)%i1) end do case (EVAL_IDENTITY) call eval%set_matrix_element (eval%int_in1) case (EVAL_QN_SUM) do i = 1, size (eval%pairing_array) call eval%evaluate_me_sum (i, & eval%int_in1, eval%pairing_array(i)%i1) call eval%set_norm (eval%int_in1%get_norm ()) end do end select end subroutine evaluator_evaluate @ %def evaluator_evaluate @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[evaluators_ut.f90]]>>= <> module evaluators_ut use unit_tests use evaluators_uti <> <> contains <> end module evaluators_ut @ %def evaluators_ut @ <<[[evaluators_uti.f90]]>>= <> module evaluators_uti <> use lorentz use flavors use colors use helicities use quantum_numbers use interactions use model_data use evaluators <> <> contains <> end module evaluators_uti @ %def evaluators_ut @ API: driver for the unit tests below. <>= public :: evaluator_test <>= subroutine evaluator_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine evaluator_test @ %def evaluator_test @ Test: Create two interactions. The interactions are twofold connected. The first connection has a helicity index that is kept, the second connection has a helicity index that is summed over. Concatenate the interactions in an evaluator, which thus contains a result interaction. Fill the input interactions with values, activate the evaluator and print the result. <>= call test (evaluator_1, "evaluator_1", & "check evaluators (1)", & u, results) <>= public :: evaluator_1 <>= subroutine evaluator_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(interaction_t), target :: int_qqtt, int_tbw, int1, int2 type(flavor_t), dimension(:), allocatable :: flv type(color_t), dimension(:), allocatable :: col type(helicity_t), dimension(:), allocatable :: hel type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: f, c, h1, h2, h3 type(vector4_t), dimension(4) :: p type(vector4_t), dimension(2) :: q type(quantum_numbers_mask_t) :: qn_mask_conn type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask2 type(evaluator_t), target :: eval, eval2, eval3 call model%init_sm_test () write (u, "(A)") "*** Evaluator for matrix product" write (u, "(A)") "*** Construct interaction for qq -> tt" write (u, "(A)") call int_qqtt%basic_init (2, 0, 2, set_relations=.true.) allocate (flv (4), col (4), hel (4), qn (4)) allocate (qn_mask2 (4)) do c = 1, 2 select case (c) case (1) call col%init_col_acl ([1, 0, 1, 0], [0, 2, 0, 2]) case (2) call col%init_col_acl ([1, 0, 2, 0], [0, 1, 0, 2]) end select do f = 1, 2 call flv%init ([f, -f, 6, -6], model) do h1 = -1, 1, 2 call hel(3)%init (h1) do h2 = -1, 1, 2 call hel(4)%init (h2) call qn%init (flv, col, hel) call int_qqtt%add_state (qn) end do end do end do end do call int_qqtt%freeze () deallocate (flv, col, hel, qn) write (u, "(A)") "*** Construct interaction for t -> bW" call int_tbw%basic_init (1, 0, 2, set_relations=.true.) allocate (flv (3), col (3), hel (3), qn (3)) call flv%init ([6, 5, 24], model) call col%init_col_acl ([1, 1, 0], [0, 0, 0]) do h1 = -1, 1, 2 call hel(1)%init (h1) do h2 = -1, 1, 2 call hel(2)%init (h2) do h3 = -1, 1 call hel(3)%init (h3) call qn%init (flv, col, hel) call int_tbw%add_state (qn) end do end do end do call int_tbw%freeze () deallocate (flv, col, hel, qn) write (u, "(A)") "*** Link interactions" call int_tbw%set_source_link (1, int_qqtt, 3) qn_mask_conn = quantum_numbers_mask (.false.,.false.,.true.) write (u, "(A)") write (u, "(A)") "*** Show input" call int_qqtt%basic_write (unit = u) write (u, "(A)") call int_tbw%basic_write (unit = u) write (u, "(A)") write (u, "(A)") "*** Evaluate product" call eval%init_product (int_qqtt, int_tbw, qn_mask_conn) call eval%write (unit = u) call int1%basic_init (2, 0, 2, set_relations=.true.) call int2%basic_init (1, 0, 2, set_relations=.true.) p(1) = vector4_moving (1000._default, 1000._default, 3) p(2) = vector4_moving (200._default, 200._default, 2) p(3) = vector4_moving (100._default, 200._default, 1) p(4) = p(1) - p(2) - p(3) call int1%set_momenta (p) q(1) = vector4_moving (50._default,-50._default, 3) q(2) = p(2) + p(4) - q(1) call int2%set_momenta (q, outgoing=.true.) call int1%set_matrix_element ([(2._default,0._default), & (4._default,1._default), (-3._default,0._default)]) call int2%set_matrix_element ([(-3._default,0._default), & (0._default,1._default), (1._default,2._default)]) call eval%receive_momenta () call eval%evaluate () call int1%basic_write (unit = u) write (u, "(A)") call int2%basic_write (unit = u) write (u, "(A)") call eval%write (unit = u) write (u, "(A)") call int1%final () call int2%final () call eval%final () write (u, "(A)") write (u, "(A)") "*** Evaluator for matrix square" allocate (flv(4), col(4), qn(4)) call int1%basic_init (2, 0, 2, set_relations=.true.) call flv%init ([1, -1, 21, 21], model) call col(1)%init ([1]) call col(2)%init ([-2]) call col(3)%init ([2, -3]) call col(4)%init ([3, -1]) call qn%init (flv, col) call int1%add_state (qn) call col(3)%init ([3, -1]) call col(4)%init ([2, -3]) call qn%init (flv, col) call int1%add_state (qn) call col(3)%init ([2, -1]) call col(4)%init (.true.) call qn%init (flv, col) call int1%add_state (qn) call int1%freeze () ! [qn_mask2 not set since default is false] call eval%init_square (int1, qn_mask2, nc=3) call eval2%init_square_nondiag (int1, qn_mask2) qn_mask2 = quantum_numbers_mask (.false., .true., .true.) call eval3%init_square_diag (eval, qn_mask2) call int1%set_matrix_element & ([(2._default,0._default), & (4._default,1._default), (-3._default,0._default)]) call int1%set_momenta (p) call int1%basic_write (unit = u) write (u, "(A)") call eval%receive_momenta () call eval%evaluate () call eval%write (unit = u) write (u, "(A)") call eval2%receive_momenta () call eval2%evaluate () call eval2%write (unit = u) write (u, "(A)") call eval3%receive_momenta () call eval3%evaluate () call eval3%write (unit = u) call int1%final () call eval%final () call eval2%final () call eval3%final () call model%final () end subroutine evaluator_1 @ %def evaluator_1 @ <>= call test (evaluator_2, "evaluator_2", & "check evaluators (2)", & u, results) <>= public :: evaluator_2 <>= subroutine evaluator_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(interaction_t), target :: int integer :: h1, h2, h3, h4 type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col type(flavor_t), dimension(4) :: flv type(quantum_numbers_t), dimension(4) :: qn type(vector4_t), dimension(4) :: p type(evaluator_t) :: eval integer :: i call model%init_sm_test () write (u, "(A)") "*** Creating interaction for e+ e- -> W+ W-" write (u, "(A)") call flv%init ([11, -11, 24, -24], model) do i = 1, 4 call col(i)%init () end do call int%basic_init (2, 0, 2, set_relations=.true.) do h1 = -1, 1, 2 call hel(1)%init (h1) do h2 = -1, 1, 2 call hel(2)%init (h2) do h3 = -1, 1 call hel(3)%init (h3) do h4 = -1, 1 call hel(4)%init (h4) call qn%init (flv, col, hel) call int%add_state (qn) end do end do end do end do call int%freeze () call int%set_matrix_element & ([(cmplx (i, kind=default), i = 1, 36)]) p(1) = vector4_moving (1000._default, 1000._default, 3) p(2) = vector4_moving (1000._default, -1000._default, 3) p(3) = vector4_moving (1000._default, & sqrt (1E6_default - 80._default**2), 3) p(4) = p(1) + p(2) - p(3) call int%set_momenta (p) write (u, "(A)") "*** Setting up evaluator" write (u, "(A)") call eval%init_identity (int) write (u, "(A)") "*** Transferring momenta and evaluating" write (u, "(A)") call eval%receive_momenta () call eval%evaluate () write (u, "(A)") "*******************************************************" write (u, "(A)") " Interaction dump" write (u, "(A)") "*******************************************************" call int%basic_write (unit = u) write (u, "(A)") write (u, "(A)") "*******************************************************" write (u, "(A)") " Evaluator dump" write (u, "(A)") "*******************************************************" call eval%write (unit = u) write (u, "(A)") write (u, "(A)") "*** cleaning up" call int%final () call eval%final () call model%final () end subroutine evaluator_2 @ %def evaluator_2 @ <>= call test (evaluator_3, "evaluator_3", & "check evaluators (3)", & u, results) <>= public :: evaluator_3 <>= subroutine evaluator_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(interaction_t), target :: int integer :: h1, h2, h3, h4 type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col type(flavor_t), dimension(4) :: flv1, flv2 type(quantum_numbers_t), dimension(4) :: qn type(vector4_t), dimension(4) :: p type(evaluator_t) :: eval1, eval2, eval3 type(quantum_numbers_mask_t), dimension(4) :: qn_mask integer :: i call model%init_sm_test () write (u, "(A)") "*** Creating interaction for e+/mu+ e-/mu- -> W+ W-" call flv1%init ([11, -11, 24, -24], model) call flv2%init ([13, -13, 24, -24], model) do i = 1, 4 call col (i)%init () end do call int%basic_init (2, 0, 2, set_relations=.true.) do h1 = -1, 1, 2 call hel(1)%init (h1) do h2 = -1, 1, 2 call hel(2)%init (h2) do h3 = -1, 1 call hel(3)%init (h3) do h4 = -1, 1 call hel(4)%init (h4) call qn%init (flv1, col, hel) call int%add_state (qn) call qn%init (flv2, col, hel) call int%add_state (qn) end do end do end do end do call int%freeze () call int%set_matrix_element & ([(cmplx (1, kind=default), i = 1, 72)]) p(1) = vector4_moving (1000._default, 1000._default, 3) p(2) = vector4_moving (1000._default, -1000._default, 3) p(3) = vector4_moving (1000._default, & sqrt (1E6_default - 80._default**2), 3) p(4) = p(1) + p(2) - p(3) call int%set_momenta (p) write (u, "(A)") "*** Setting up evaluators" call qn_mask%init (.false., .true., .true.) call eval1%init_qn_sum (int, qn_mask) call qn_mask%init (.true., .true., .true.) call eval2%init_qn_sum (int, qn_mask) call qn_mask%init (.false., .true., .false.) call eval3%init_qn_sum (int, qn_mask, & [.false., .false., .false., .true.]) write (u, "(A)") "*** Transferring momenta and evaluating" call eval1%receive_momenta () call eval1%evaluate () call eval2%receive_momenta () call eval2%evaluate () call eval3%receive_momenta () call eval3%evaluate () write (u, "(A)") "*******************************************************" write (u, "(A)") " Interaction dump" write (u, "(A)") "*******************************************************" call int%basic_write (unit = u) write (u, "(A)") write (u, "(A)") "*******************************************************" write (u, "(A)") " Evaluator dump --- spin sum" write (u, "(A)") "*******************************************************" call eval1%write (unit = u) call eval1%basic_write (unit = u) write (u, "(A)") "*******************************************************" write (u, "(A)") " Evaluator dump --- spin / flavor sum" write (u, "(A)") "*******************************************************" call eval2%write (unit = u) call eval2%basic_write (unit = u) write (u, "(A)") "*******************************************************" write (u, "(A)") " Evaluator dump --- flavor sum, drop last W" write (u, "(A)") "*******************************************************" call eval3%write (unit = u) call eval3%basic_write (unit = u) write (u, "(A)") write (u, "(A)") "*** cleaning up" call int%final () call eval1%final () call eval2%final () call eval3%final () call model%final () end subroutine evaluator_3 @ %def evaluator_3 @ This test evaluates a product with different quantum-number masks and filters for the linked entry. <>= call test (evaluator_4, "evaluator_4", & "check evaluator product with filter", & u, results) <>= public :: evaluator_4 <>= subroutine evaluator_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(interaction_t), target :: int1, int2 integer :: h1, h2, h3 type(helicity_t), dimension(3) :: hel type(color_t), dimension(3) :: col type(flavor_t), dimension(2) :: flv1, flv2 type(flavor_t), dimension(3) :: flv3, flv4 type(quantum_numbers_t), dimension(3) :: qn type(evaluator_t) :: eval1, eval2, eval3, eval4 type(quantum_numbers_mask_t) :: qn_mask type(flavor_t) :: flv_filter type(helicity_t) :: hel_filter type(color_t) :: col_filter type(quantum_numbers_t) :: qn_filter integer :: i write (u, "(A)") "* Test output: evaluator_4" write (u, "(A)") "* Purpose: test evaluator products & &with mask and filter" write (u, "(A)") call model%init_sm_test () write (u, "(A)") "* Creating interaction for e- -> W+/Z" write (u, "(A)") call flv1%init ([11, 24], model) call flv2%init ([11, 23], model) do i = 1, 3 call col(i)%init () end do call int1%basic_init (1, 0, 1, set_relations=.true.) do h1 = -1, 1, 2 call hel(1)%init (h1) do h2 = -1, 1 call hel(2)%init (h2) call qn(:2)%init (flv1, col(:2), hel(:2)) call int1%add_state (qn(:2)) call qn(:2)%init (flv2, col(:2), hel(:2)) call int1%add_state (qn(:2)) end do end do call int1%freeze () call int1%basic_write (u) write (u, "(A)") write (u, "(A)") "* Creating interaction for W+/Z -> u ubar/dbar" write (u, "(A)") call flv3%init ([24, 2, -1], model) call flv4%init ([23, 2, -2], model) call int2%basic_init (1, 0, 2, set_relations=.true.) do h1 = -1, 1 call hel(1)%init (h1) do h2 = -1, 1, 2 call hel(2)%init (h2) do h3 = -1, 1, 2 call hel(3)%init (h3) call qn(:3)%init (flv3, col(:3), hel(:3)) call int2%add_state (qn(:3)) call qn(:3)%init (flv4, col(:3), hel(:3)) call int2%add_state (qn(:3)) end do end do end do call int2%freeze () call int2%set_source_link (1, int1, 2) call int2%basic_write (u) write (u, "(A)") write (u, "(A)") "* Product evaluator" write (u, "(A)") call qn_mask%init (.false., .false., .false.) call eval1%init_product (int1, int2, qn_mask_conn = qn_mask) call eval1%write (u) write (u, "(A)") write (u, "(A)") "* Product evaluator with helicity mask" write (u, "(A)") call qn_mask%init (.false., .false., .true.) call eval2%init_product (int1, int2, qn_mask_conn = qn_mask) call eval2%write (u) write (u, "(A)") write (u, "(A)") "* Product with flavor filter and helicity mask" write (u, "(A)") call qn_mask%init (.false., .false., .true.) call flv_filter%init (24, model) call hel_filter%init () call col_filter%init () call qn_filter%init (flv_filter, col_filter, hel_filter) call eval3%init_product (int1, int2, & qn_mask_conn = qn_mask, qn_filter_conn = qn_filter) call eval3%write (u) write (u, "(A)") write (u, "(A)") "* Product with helicity filter and mask" write (u, "(A)") call qn_mask%init (.false., .false., .true.) call flv_filter%init () call hel_filter%init (0) call col_filter%init () call qn_filter%init (flv_filter, col_filter, hel_filter) call eval4%init_product (int1, int2, & qn_mask_conn = qn_mask, qn_filter_conn = qn_filter) call eval4%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eval1%final () call eval2%final () call eval3%final () call eval4%final () call int1%final () call int2%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: evaluator_4" end subroutine evaluator_4 @ %def evaluator_4 Index: trunk/src/model_features/model_features.nw =================================================================== --- trunk/src/model_features/model_features.nw (revision 8456) +++ trunk/src/model_features/model_features.nw (revision 8457) @@ -1,17248 +1,17258 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: model features %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Model Handling and Features} \includemodulegraph{model_features} These modules deal with process definitions and physics models. These modules use the [[model_data]] methods to automatically generate process definitions. \begin{description} \item[auto\_components] Generic process-definition generator. We can specify a basic process or initial particle(s) and some rules to extend this process, given a model definition with particle names and vertex structures. \item[radiation\_generator] Applies the generic generator to the specific problem of generating NLO corrections in a restricted setup. \end{description} Model construction: \begin{description} \item[eval\_trees] Implementation of the generic [[expr_t]] type for the concrete evaluation of expressions that access user variables. This module is actually part of the Sindarin language implementation, and should be moved elsewhere. Currently, the [[models]] module relies on it. \item[models] Extends the [[model_data_t]] structure by user-variable objects for easy access, and provides the means to read a model definition from file. \item[slha\_interface] Read/write a SUSY model in the standardized SLHA format. The format defines fields and parameters, but no vertices. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Automatic generation of process components} This module provides the functionality for automatically generating radiation corrections or decays, provided as lists of PDG codes. <<[[auto_components.f90]]>>= <> module auto_components <> <> use io_units use diagnostics use model_data use pdg_arrays use physics_defs, only: PHOTON, GLUON, Z_BOSON, W_BOSON use numeric_utils, only: extend_integer_array <> <> <> <> <> contains <> end module auto_components @ %def auto_components @ \subsection{Constraints: Abstract types} An abstract type that denotes a constraint on the automatically generated states. The concrete objects are applied as visitor objects at certain hooks during the splitting algorithm. <>= type, abstract :: split_constraint_t contains <> end type split_constraint_t @ %def split_constraint_t @ By default, all checks return true. <>= procedure :: check_before_split => split_constraint_check_before_split procedure :: check_before_insert => split_constraint_check_before_insert procedure :: check_before_record => split_constraint_check_before_record <>= subroutine split_constraint_check_before_split (c, table, pl, k, passed) class(split_constraint_t), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: k logical, intent(out) :: passed passed = .true. end subroutine split_constraint_check_before_split subroutine split_constraint_check_before_insert (c, table, pa, pl, passed) class(split_constraint_t), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed passed = .true. end subroutine split_constraint_check_before_insert subroutine split_constraint_check_before_record (c, table, pl, n_loop, passed) class(split_constraint_t), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed passed = .true. end subroutine split_constraint_check_before_record @ %def check_before_split @ %def check_before_insert @ %def check_before_record @ A transparent wrapper, so we can collect constraints of different type. <>= type :: split_constraint_wrap_t class(split_constraint_t), allocatable :: c end type split_constraint_wrap_t @ %def split_constraint_wrap_t @ A collection of constraints. <>= public :: split_constraints_t <>= type :: split_constraints_t class(split_constraint_wrap_t), dimension(:), allocatable :: cc contains <> end type split_constraints_t @ %def split_constraints_t @ Initialize the constraints set with a specific number of elements. <>= procedure :: init => split_constraints_init <>= subroutine split_constraints_init (constraints, n) class(split_constraints_t), intent(out) :: constraints integer, intent(in) :: n allocate (constraints%cc (n)) end subroutine split_constraints_init @ %def split_constraints_init @ Set a constraint. <>= procedure :: set => split_constraints_set <>= subroutine split_constraints_set (constraints, i, c) class(split_constraints_t), intent(inout) :: constraints integer, intent(in) :: i class(split_constraint_t), intent(in) :: c allocate (constraints%cc(i)%c, source = c) end subroutine split_constraints_set @ %def split_constraints_set @ Apply checks. [[check_before_split]] is applied to the particle list that we want to split. [[check_before_insert]] is applied to the particle list [[pl]] that is to replace the particle [[pa]] that is split. This check may transform the particle list. [[check_before_record]] is applied to the complete new particle list that results from splitting before it is recorded. <>= procedure :: check_before_split => split_constraints_check_before_split procedure :: check_before_insert => split_constraints_check_before_insert procedure :: check_before_record => split_constraints_check_before_record <>= subroutine split_constraints_check_before_split & (constraints, table, pl, k, passed) class(split_constraints_t), intent(in) :: constraints class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: k logical, intent(out) :: passed integer :: i passed = .true. do i = 1, size (constraints%cc) call constraints%cc(i)%c%check_before_split (table, pl, k, passed) if (.not. passed) return end do end subroutine split_constraints_check_before_split subroutine split_constraints_check_before_insert & (constraints, table, pa, pl, passed) class(split_constraints_t), intent(in) :: constraints class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed integer :: i passed = .true. do i = 1, size (constraints%cc) call constraints%cc(i)%c%check_before_insert (table, pa, pl, passed) if (.not. passed) return end do end subroutine split_constraints_check_before_insert subroutine split_constraints_check_before_record & (constraints, table, pl, n_loop, passed) class(split_constraints_t), intent(in) :: constraints class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed integer :: i passed = .true. do i = 1, size (constraints%cc) call constraints%cc(i)%c%check_before_record (table, pl, n_loop, passed) if (.not. passed) return end do end subroutine split_constraints_check_before_record @ %def split_constraints_check_before_split @ %def split_constraints_check_before_insert @ %def split_constraints_check_before_record @ \subsection{Specific constraints} \subsubsection{Number of particles} Specific constraint: The number of particles plus the number of loops, if any, must remain less than the given limit. Note that the number of loops is defined only when we are recording the entry. <>= type, extends (split_constraint_t) :: constraint_n_tot private integer :: n_max = 0 contains procedure :: check_before_split => constraint_n_tot_check_before_split procedure :: check_before_record => constraint_n_tot_check_before_record end type constraint_n_tot @ %def constraint_n_tot <>= public :: constrain_n_tot <>= function constrain_n_tot (n_max) result (c) integer, intent(in) :: n_max type(constraint_n_tot) :: c c%n_max = n_max end function constrain_n_tot subroutine constraint_n_tot_check_before_split (c, table, pl, k, passed) class(constraint_n_tot), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: k logical, intent(out) :: passed passed = pl%get_size () < c%n_max end subroutine constraint_n_tot_check_before_split subroutine constraint_n_tot_check_before_record (c, table, pl, n_loop, passed) class(constraint_n_tot), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed passed = pl%get_size () + n_loop <= c%n_max end subroutine constraint_n_tot_check_before_record @ %def constrain_n_tot @ %def constraint_n_tot_check_before_insert @ \subsubsection{Number of loops} Specific constraint: The number of loops is limited, independent of the total number of particles. <>= type, extends (split_constraint_t) :: constraint_n_loop private integer :: n_loop_max = 0 contains procedure :: check_before_record => constraint_n_loop_check_before_record end type constraint_n_loop @ %def constraint_n_loop <>= public :: constrain_n_loop <>= function constrain_n_loop (n_loop_max) result (c) integer, intent(in) :: n_loop_max type(constraint_n_loop) :: c c%n_loop_max = n_loop_max end function constrain_n_loop subroutine constraint_n_loop_check_before_record & (c, table, pl, n_loop, passed) class(constraint_n_loop), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed passed = n_loop <= c%n_loop_max end subroutine constraint_n_loop_check_before_record @ %def constrain_n_loop @ %def constraint_n_loop_check_before_insert @ \subsubsection{Particles allowed in splitting} Specific constraint: The entries in the particle list ready for insertion are matched to a given list of particle patterns. If a match occurs, the entry is replaced by the corresponding pattern. If there is no match, the check fails. If a massless gauge boson splitting is detected, the splitting partners are checked against a list of excluded particles. If a match occurs, the check fails. <>= type, extends (split_constraint_t) :: constraint_splittings private type(pdg_list_t) :: pl_match, pl_excluded_gauge_splittings contains procedure :: check_before_insert => constraint_splittings_check_before_insert end type constraint_splittings @ %def constraint_splittings <>= public :: constrain_splittings <>= function constrain_splittings (pl_match, pl_excluded_gauge_splittings) result (c) type(pdg_list_t), intent(in) :: pl_match type(pdg_list_t), intent(in) :: pl_excluded_gauge_splittings type(constraint_splittings) :: c c%pl_match = pl_match c%pl_excluded_gauge_splittings = pl_excluded_gauge_splittings end function constrain_splittings subroutine constraint_splittings_check_before_insert (c, table, pa, pl, passed) class(constraint_splittings), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed logical :: has_massless_vector integer :: i has_massless_vector = .false. do i = 1, pa%get_length () if (is_massless_vector(pa%get(i))) then has_massless_vector = .true. exit end if end do passed = .false. if (has_massless_vector .and. count (is_fermion(pl%a%get ())) == 2) then do i = 1, c%pl_excluded_gauge_splittings%get_size () if (pl .match. c%pl_excluded_gauge_splittings%a(i)) return end do call pl%match_replace (c%pl_match, passed) passed = .true. else call pl%match_replace (c%pl_match, passed) end if end subroutine constraint_splittings_check_before_insert @ %def constrain_splittings @ %def constraint_splittings_check_before_insert @ Specific constraint: The entries in the particle list ready for insertion are matched to a given list of particle patterns. If a match occurs, the entry is replaced by the corresponding pattern. If there is no match, the check fails. <>= type, extends (split_constraint_t) :: constraint_insert private type(pdg_list_t) :: pl_match contains procedure :: check_before_insert => constraint_insert_check_before_insert end type constraint_insert @ %def constraint_insert <>= public :: constrain_insert <>= function constrain_insert (pl_match) result (c) type(pdg_list_t), intent(in) :: pl_match type(constraint_insert) :: c c%pl_match = pl_match end function constrain_insert subroutine constraint_insert_check_before_insert (c, table, pa, pl, passed) class(constraint_insert), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed call pl%match_replace (c%pl_match, passed) end subroutine constraint_insert_check_before_insert @ %def constrain_insert @ %def constraint_insert_check_before_insert @ \subsubsection{Particles required in final state} Specific constraint: The entries in the recorded state must be a superset of the entries in the given list (for instance, the lowest-order state). <>= type, extends (split_constraint_t) :: constraint_require private type(pdg_list_t) :: pl contains procedure :: check_before_record => constraint_require_check_before_record end type constraint_require @ %def constraint_require @ We check the current state by matching all particle entries against the stored particle list, and crossing out the particles in the latter list when a match is found. The constraint passed if all entries have been crossed out. For an [[if_table]] in particular, we check the final state only. <>= public :: constrain_require <>= function constrain_require (pl) result (c) type(pdg_list_t), intent(in) :: pl type(constraint_require) :: c c%pl = pl end function constrain_require subroutine constraint_require_check_before_record & (c, table, pl, n_loop, passed) class(constraint_require), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed logical, dimension(:), allocatable :: mask integer :: i, k, n_in select type (table) type is (if_table_t) if (table%proc_type > 0) then select case (table%proc_type) case (PROC_DECAY) n_in = 1 case (PROC_SCATTER) n_in = 2 end select else call msg_fatal ("Neither a decay nor a scattering process") end if class default n_in = 0 end select allocate (mask (c%pl%get_size ()), source = .true.) do i = n_in + 1, pl%get_size () k = c%pl%find_match (pl%get (i), mask) if (k /= 0) mask(k) = .false. end do passed = .not. any (mask) end subroutine constraint_require_check_before_record @ %def constrain_require @ %def constraint_require_check_before_record @ \subsubsection{Radiation} Specific constraint: We have radiation pattern if the original particle matches an entry in the list of particles that should replace it. The constraint prohibits this situation. <>= public :: constrain_radiation <>= type, extends (split_constraint_t) :: constraint_radiation private contains procedure :: check_before_insert => & constraint_radiation_check_before_insert end type constraint_radiation @ %def constraint_radiation <>= function constrain_radiation () result (c) type(constraint_radiation) :: c end function constrain_radiation subroutine constraint_radiation_check_before_insert (c, table, pa, pl, passed) class(constraint_radiation), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed passed = .not. (pl .match. pa) end subroutine constraint_radiation_check_before_insert @ %def constrain_radiation @ %def constraint_radiation_check_before_insert @ \subsubsection{Mass sum} Specific constraint: The sum of masses within the particle list must be smaller than a given limit. For in/out state combinations, we check initial and final state separately. If we specify [[margin]] in the initialization, the sum must be strictly less than the limit minus the given margin (which may be zero). If not, equality is allowed. <>= public :: constrain_mass_sum <>= type, extends (split_constraint_t) :: constraint_mass_sum private real(default) :: mass_limit = 0 logical :: strictly_less = .false. real(default) :: margin = 0 contains procedure :: check_before_record => constraint_mass_sum_check_before_record end type constraint_mass_sum @ %def contraint_mass_sum <>= function constrain_mass_sum (mass_limit, margin) result (c) real(default), intent(in) :: mass_limit real(default), intent(in), optional :: margin type(constraint_mass_sum) :: c c%mass_limit = mass_limit if (present (margin)) then c%strictly_less = .true. c%margin = margin end if end function constrain_mass_sum subroutine constraint_mass_sum_check_before_record & (c, table, pl, n_loop, passed) class(constraint_mass_sum), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed real(default) :: limit if (c%strictly_less) then limit = c%mass_limit - c%margin select type (table) type is (if_table_t) passed = mass_sum (pl, 1, 2, table%model) < limit & .and. mass_sum (pl, 3, pl%get_size (), table%model) < limit class default passed = mass_sum (pl, 1, pl%get_size (), table%model) < limit end select else limit = c%mass_limit select type (table) type is (if_table_t) passed = mass_sum (pl, 1, 2, table%model) <= limit & .and. mass_sum (pl, 3, pl%get_size (), table%model) <= limit class default passed = mass_sum (pl, 1, pl%get_size (), table%model) <= limit end select end if end subroutine constraint_mass_sum_check_before_record @ %def constrain_mass_sum @ %def constraint_mass_sum_check_before_record @ \subsubsection{Initial state particles} Specific constraint: The two incoming particles must both match the given particle list. This is checked for the generated particle list, just before it is recorded. <>= public :: constrain_in_state <>= type, extends (split_constraint_t) :: constraint_in_state private type(pdg_list_t) :: pl contains procedure :: check_before_record => constraint_in_state_check_before_record end type constraint_in_state @ %def constraint_in_state <>= function constrain_in_state (pl) result (c) type(pdg_list_t), intent(in) :: pl type(constraint_in_state) :: c c%pl = pl end function constrain_in_state subroutine constraint_in_state_check_before_record & (c, table, pl, n_loop, passed) class(constraint_in_state), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed integer :: i select type (table) type is (if_table_t) passed = .false. do i = 1, 2 if (.not. (c%pl .match. pl%get (i))) return end do end select passed = .true. end subroutine constraint_in_state_check_before_record @ %def constrain_in_state @ %def constraint_in_state_check_before_record @ \subsubsection{Photon induced processes} If set, filter out photon induced processes. <>= public :: constrain_photon_induced_processes <>= type, extends (split_constraint_t) :: constraint_photon_induced_processes private integer :: n_in contains procedure :: check_before_record => & constraint_photon_induced_processes_check_before_record end type constraint_photon_induced_processes @ %def constraint_photon_induced_processes <>= function constrain_photon_induced_processes (n_in) result (c) integer, intent(in) :: n_in type(constraint_photon_induced_processes) :: c c%n_in = n_in end function constrain_photon_induced_processes subroutine constraint_photon_induced_processes_check_before_record & (c, table, pl, n_loop, passed) class(constraint_photon_induced_processes), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed integer :: i select type (table) type is (if_table_t) passed = .false. do i = 1, c%n_in if (pl%a(i)%get () == 22) return end do end select passed = .true. end subroutine constraint_photon_induced_processes_check_before_record @ %def constrain_photon_induced_processes @ %def constraint_photon_induced_processes_check_before_record @ \subsubsection{Coupling constraint} Filters vertices which do not match the desired NLO pattern. <>= type, extends (split_constraint_t) :: constraint_coupling_t private logical :: qed = .false. logical :: qcd = .true. logical :: ew = .false. integer :: n_nlo_correction_types contains <> end type constraint_coupling_t @ %def constraint_coupling_t @ <>= public :: constrain_couplings <>= function constrain_couplings (qcd, qed, n_nlo_correction_types) result (c) type(constraint_coupling_t) :: c logical, intent(in) :: qcd, qed integer, intent(in) :: n_nlo_correction_types c%qcd = qcd; c%qed = qed c%n_nlo_correction_types = n_nlo_correction_types end function constrain_couplings @ %def constrain_couplings @ <>= procedure :: check_before_insert => constraint_coupling_check_before_insert <>= subroutine constraint_coupling_check_before_insert (c, table, pa, pl, passed) class(constraint_coupling_t), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed type(pdg_list_t) :: pl_vertex type(pdg_array_t) :: pdg_gluon, pdg_photon, pdg_W_Z, pdg_gauge_bosons integer :: i, j pdg_gluon = GLUON; pdg_photon = PHOTON pdg_W_Z = [W_BOSON,-W_BOSON, Z_BOSON] if (c%qcd) pdg_gauge_bosons = pdg_gauge_bosons // pdg_gluon if (c%qed) pdg_gauge_bosons = pdg_gauge_bosons // pdg_photon if (c%ew) pdg_gauge_bosons = pdg_gauge_bosons // pdg_W_Z do j = 1, pa%get_length () call pl_vertex%init (pl%get_size () + 1) call pl_vertex%set (1, pa%get(j)) do i = 1, pl%get_size () call pl_vertex%set (i + 1, pl%get(i)) end do if (pl_vertex%get_size () > 3) then passed = .false. cycle end if if (is_massless_vector(pa%get(j))) then if (.not. table%model%check_vertex & (pl_vertex%a(1)%get (), pl_vertex%a(2)%get (), pl_vertex%a(3)%get ())) then passed = .false. cycle end if else if (.not. table%model%check_vertex & (- pl_vertex%a(1)%get (), pl_vertex%a(2)%get (), pl_vertex%a(3)%get ())) then passed = .false. cycle end if if (.not. (pl_vertex .match. pdg_gauge_bosons)) then passed = .false. cycle end if passed = .true. exit end do end subroutine constraint_coupling_check_before_insert @ %def constraint_coupling_check_before_insert @ \subsection{Tables of states} Automatically generate a list of possible process components for a given initial set (a single massive particle or a preset list of states). The set of process components are generated by recursive splitting, applying constraints on the fly that control and limit the process. The generated states are accumulated in a table that we can read out after completion. <>= type, extends (pdg_list_t) :: ps_entry_t integer :: n_loop = 0 integer :: n_rad = 0 type(ps_entry_t), pointer :: previous => null () type(ps_entry_t), pointer :: next => null () end type ps_entry_t @ %def ps_entry_t @ <>= integer, parameter :: PROC_UNDEFINED = 0 integer, parameter :: PROC_DECAY = 1 integer, parameter :: PROC_SCATTER = 2 @ %def auto_components parameters @ This is the wrapper type for the decay tree for the list of final states and the final array. First, an abstract base type: <>= public :: ps_table_t <>= type, abstract :: ps_table_t private class(model_data_t), pointer :: model => null () logical :: loops = .false. type(ps_entry_t), pointer :: first => null () type(ps_entry_t), pointer :: last => null () integer :: proc_type contains <> end type ps_table_t @ %def ps_table_t @ The extensions: one for decay, one for generic final states. The decay-state table stores the initial particle. The final-state table is indifferent, and the initial/final state table treats the first two particles in its list as incoming antiparticles. <>= public :: ds_table_t public :: fs_table_t public :: if_table_t <>= type, extends (ps_table_t) :: ds_table_t private integer :: pdg_in = 0 contains <> end type ds_table_t type, extends (ps_table_t) :: fs_table_t contains <> end type fs_table_t type, extends (fs_table_t) :: if_table_t contains <> end type if_table_t @ %def ds_table_t fs_table_t if_table_t @ Finalizer: we must deallocate the embedded list. <>= procedure :: final => ps_table_final <>= subroutine ps_table_final (object) class(ps_table_t), intent(inout) :: object type(ps_entry_t), pointer :: current do while (associated (object%first)) current => object%first object%first => current%next deallocate (current) end do nullify (object%last) end subroutine ps_table_final @ %def ps_table_final @ Write the table. A base writer for the body and specific writers for the headers. <>= procedure :: base_write => ps_table_base_write procedure (ps_table_write), deferred :: write <>= interface subroutine ps_table_write (object, unit) import class(ps_table_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine ps_table_write end interface <>= procedure :: write => ds_table_write <>= procedure :: write => fs_table_write <>= procedure :: write => if_table_write @ The first [[n_in]] particles will be replaced by antiparticles in the output, and we write an arrow if [[n_in]] is present. <>= subroutine ps_table_base_write (object, unit, n_in) class(ps_table_t), intent(in) :: object integer, intent(in), optional :: unit integer, intent(in), optional :: n_in integer, dimension(:), allocatable :: pdg type(ps_entry_t), pointer :: entry type(field_data_t), pointer :: prt integer :: u, i, j, n0 u = given_output_unit (unit) entry => object%first do while (associated (entry)) write (u, "(2x)", advance = "no") if (present (n_in)) then do i = 1, n_in write (u, "(1x)", advance = "no") pdg = entry%get (i) do j = 1, size (pdg) prt => object%model%get_field_ptr (pdg(j)) if (j > 1) write (u, "(':')", advance = "no") write (u, "(A)", advance = "no") & char (prt%get_name (pdg(j) >= 0)) end do end do write (u, "(1x,A)", advance = "no") "=>" n0 = n_in + 1 else n0 = 1 end if do i = n0, entry%get_size () write (u, "(1x)", advance = "no") pdg = entry%get (i) do j = 1, size (pdg) prt => object%model%get_field_ptr (pdg(j)) if (j > 1) write (u, "(':')", advance = "no") write (u, "(A)", advance = "no") & char (prt%get_name (pdg(j) < 0)) end do end do if (object%loops) then write (u, "(2x,'[',I0,',',I0,']')") entry%n_loop, entry%n_rad else write (u, "(A)") end if entry => entry%next end do end subroutine ps_table_base_write subroutine ds_table_write (object, unit) class(ds_table_t), intent(in) :: object integer, intent(in), optional :: unit type(field_data_t), pointer :: prt integer :: u u = given_output_unit (unit) prt => object%model%get_field_ptr (object%pdg_in) write (u, "(1x,A,1x,A)") "Decays for particle:", & char (prt%get_name (object%pdg_in < 0)) call object%base_write (u) end subroutine ds_table_write subroutine fs_table_write (object, unit) class(fs_table_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Table of final states:" call object%base_write (u) end subroutine fs_table_write subroutine if_table_write (object, unit) class(if_table_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Table of in/out states:" select case (object%proc_type) case (PROC_DECAY) call object%base_write (u, n_in = 1) case (PROC_SCATTER) call object%base_write (u, n_in = 2) end select end subroutine if_table_write @ %def ps_table_write ds_table_write fs_table_write @ Obtain a particle string for a given index in the pdg list <>= procedure :: get_particle_string => ps_table_get_particle_string <>= subroutine ps_table_get_particle_string (object, index, prt_in, prt_out) class(ps_table_t), intent(in) :: object integer, intent(in) :: index type(string_t), intent(out), dimension(:), allocatable :: prt_in, prt_out integer :: n_in type(field_data_t), pointer :: prt type(ps_entry_t), pointer :: entry integer, dimension(:), allocatable :: pdg integer :: n0 integer :: i, j entry => object%first i = 1 do while (i < index) if (associated (entry%next)) then entry => entry%next i = i + 1 else call msg_fatal ("ps_table: entry with requested index does not exist!") end if end do if (object%proc_type > 0) then select case (object%proc_type) case (PROC_DECAY) n_in = 1 case (PROC_SCATTER) n_in = 2 end select else call msg_fatal ("Neither decay nor scattering process") end if n0 = n_in + 1 allocate (prt_in (n_in), prt_out (entry%get_size () - n_in)) do i = 1, n_in prt_in(i) = "" pdg = entry%get(i) do j = 1, size (pdg) prt => object%model%get_field_ptr (pdg(j)) prt_in(i) = prt_in(i) // prt%get_name (pdg(j) >= 0) if (j /= size (pdg)) prt_in(i) = prt_in(i) // ":" end do end do do i = n0, entry%get_size () prt_out(i-n_in) = "" pdg = entry%get(i) do j = 1, size (pdg) prt => object%model%get_field_ptr (pdg(j)) prt_out(i-n_in) = prt_out(i-n_in) // prt%get_name (pdg(j) < 0) if (j /= size (pdg)) prt_out(i-n_in) = prt_out(i-n_in) // ":" end do end do end subroutine ps_table_get_particle_string @ %def ps_table_get_particle_string @ Initialize with a predefined set of final states, or in/out state lists. <>= generic :: init => ps_table_init procedure, private :: ps_table_init <>= generic :: init => if_table_init procedure, private :: if_table_init <>= subroutine ps_table_init (table, model, pl, constraints, n_in, do_not_check_regular) class(ps_table_t), intent(out) :: table class(model_data_t), intent(in), target :: model type(pdg_list_t), dimension(:), intent(in) :: pl type(split_constraints_t), intent(in) :: constraints integer, intent(in), optional :: n_in logical, intent(in), optional :: do_not_check_regular logical :: passed integer :: i table%model => model if (present (n_in)) then select case (n_in) case (1) table%proc_type = PROC_DECAY case (2) table%proc_type = PROC_SCATTER case default table%proc_type = PROC_UNDEFINED end select else table%proc_type = PROC_UNDEFINED end if do i = 1, size (pl) call table%record (pl(i), 0, 0, constraints, & do_not_check_regular, passed) if (.not. passed) then call msg_fatal ("ps_table: Registering process components failed") end if end do end subroutine ps_table_init subroutine if_table_init (table, model, pl_in, pl_out, constraints) class(if_table_t), intent(out) :: table class(model_data_t), intent(in), target :: model type(pdg_list_t), dimension(:), intent(in) :: pl_in, pl_out type(split_constraints_t), intent(in) :: constraints integer :: i, j, k, p, n_in, n_out type(pdg_array_t), dimension(:), allocatable :: pa_in type(pdg_list_t), dimension(:), allocatable :: pl allocate (pl (size (pl_in) * size (pl_out))) k = 0 do i = 1, size (pl_in) n_in = pl_in(i)%get_size () allocate (pa_in (n_in)) do p = 1, n_in pa_in(p) = pl_in(i)%get (p) end do do j = 1, size (pl_out) n_out = pl_out(j)%get_size () k = k + 1 call pl(k)%init (n_in + n_out) do p = 1, n_in call pl(k)%set (p, invert_pdg_array (pa_in(p), model)) end do do p = 1, n_out call pl(k)%set (n_in + p, pl_out(j)%get (p)) end do end do deallocate (pa_in) end do n_in = size (pl_in(1)%a) call table%init (model, pl, constraints, n_in, do_not_check_regular = .true.) end subroutine if_table_init @ %def ps_table_init if_table_init @ Enable loops for the table. This affects both splitting and output. <>= procedure :: enable_loops => ps_table_enable_loops <>= subroutine ps_table_enable_loops (table) class(ps_table_t), intent(inout) :: table table%loops = .true. end subroutine ps_table_enable_loops @ %def ps_table_enable_loops @ \subsection{Top-level methods} Create a table for a single-particle decay. Construct all possible final states from a single particle with PDG code [[pdg_in]]. The construction is limited by the given [[constraints]]. <>= procedure :: make => ds_table_make <>= subroutine ds_table_make (table, model, pdg_in, constraints) class(ds_table_t), intent(out) :: table class(model_data_t), intent(in), target :: model integer, intent(in) :: pdg_in type(split_constraints_t), intent(in) :: constraints type(pdg_list_t) :: pl_in type(pdg_list_t), dimension(0) :: pl call table%init (model, pl, constraints) table%pdg_in = pdg_in call pl_in%init (1) call pl_in%set (1, [pdg_in]) call table%split (pl_in, 0, constraints) end subroutine ds_table_make @ %def ds_table_make @ Split all entries in a growing table, starting from a table that may already contain states. Add and record split states on the fly. <>= procedure :: radiate => fs_table_radiate <>= subroutine fs_table_radiate (table, constraints, do_not_check_regular) class(fs_table_t), intent(inout) :: table type(split_constraints_t) :: constraints logical, intent(in), optional :: do_not_check_regular type(ps_entry_t), pointer :: current current => table%first do while (associated (current)) call table%split (current, 0, constraints, record = .true., & do_not_check_regular = do_not_check_regular) current => current%next end do end subroutine fs_table_radiate @ %def fs_table_radiate @ \subsection{Splitting algorithm} Recursive splitting. First of all, we record the current [[pdg_list]] in the table, subject to [[constraints]], if requested. We also record copies of the list marked as loop corrections. When we record a particle list, we sort it first. If there is room for splitting, We take a PDG array list and the index of an element, and split this element in all possible ways. The split entry is inserted into the list, which we split further. The recursion terminates whenever the split array would have a length greater than $n_\text{max}$. <>= procedure :: split => ps_table_split <>= recursive subroutine ps_table_split (table, pl, n_rad, constraints, & record, do_not_check_regular) class(ps_table_t), intent(inout) :: table class(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_rad type(split_constraints_t), intent(in) :: constraints logical, intent(in), optional :: record, do_not_check_regular integer :: n_loop, i logical :: passed, save_pdg_index type(vertex_iterator_t) :: vit integer, dimension(:), allocatable :: pdg1 integer, dimension(:), allocatable :: pdg2 if (present (record)) then if (record) then n_loop = 0 INCR_LOOPS: do call table%record_sorted (pl, n_loop, n_rad, constraints, & do_not_check_regular, passed) if (.not. passed) exit INCR_LOOPS if (.not. table%loops) exit INCR_LOOPS n_loop = n_loop + 1 end do INCR_LOOPS end if end if select type (table) type is (if_table_t) save_pdg_index = .true. class default save_pdg_index = .false. end select do i = 1, pl%get_size () call constraints%check_before_split (table, pl, i, passed) if (passed) then pdg1 = pl%get (i) call vit%init (table%model, pdg1, save_pdg_index) SCAN_VERTICES: do call vit%get_next_match (pdg2) if (allocated (pdg2)) then call table%insert (pl, n_rad, i, pdg2, constraints, & do_not_check_regular = do_not_check_regular) else exit SCAN_VERTICES end if end do SCAN_VERTICES end if end do end subroutine ps_table_split @ %def ps_table_split @ The worker part: insert the list of particles found by vertex matching in place of entry [[i]] in the PDG list. Then split/record further. The [[n_in]] parameter tells the replacement routine to insert the new particles after entry [[n_in]]. Otherwise, they follow index [[i]]. <>= procedure :: insert => ps_table_insert <>= recursive subroutine ps_table_insert & (table, pl, n_rad, i, pdg, constraints, n_in, do_not_check_regular) class(ps_table_t), intent(inout) :: table class(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_rad, i integer, dimension(:), intent(in) :: pdg type(split_constraints_t), intent(in) :: constraints integer, intent(in), optional :: n_in logical, intent(in), optional :: do_not_check_regular type(pdg_list_t) :: pl_insert logical :: passed integer :: k, s s = size (pdg) call pl_insert%init (s) do k = 1, s call pl_insert%set (k, pdg(k)) end do call constraints%check_before_insert (table, pl%get (i), pl_insert, passed) if (passed) then if (.not. is_colored_isr ()) return call table%split (pl%replace (i, pl_insert, n_in), n_rad + s - 1, & constraints, record = .true., do_not_check_regular = .true.) end if contains logical function is_colored_isr () result (ok) type(pdg_list_t) :: pl_replaced ok = .true. if (present (n_in)) then if (i <= n_in) then ok = pl_insert%contains_colored_particles () if (.not. ok) then pl_replaced = pl%replace (i, pl_insert, n_in) associate (size_replaced => pl_replaced%get_pdg_sizes (), & size => pl%get_pdg_sizes ()) ok = all (size_replaced(:n_in) == size(:n_in)) end associate end if end if end if end function is_colored_isr end subroutine ps_table_insert @ %def ps_table_insert @ Special case: If we are splitting an initial particle, there is slightly more to do. We loop over the particles from the vertex match and replace the initial particle by each of them in turn. The remaining particles must be appended after the second initial particle, so they will end up in the out state. This is done by providing the [[n_in]] argument to the base method as an optional argument. Note that we must call the base-method procedure explicitly, so the [[table]] argument keeps its dynamic type as [[if_table]] inside this procedure. <>= procedure :: insert => if_table_insert <>= recursive subroutine if_table_insert & (table, pl, n_rad, i, pdg, constraints, n_in, do_not_check_regular) class(if_table_t), intent(inout) :: table class(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_rad, i integer, dimension(:), intent(in) :: pdg type(split_constraints_t), intent(in) :: constraints integer, intent(in), optional :: n_in logical, intent(in), optional :: do_not_check_regular integer, dimension(:), allocatable :: pdg_work integer :: p if (i > 2) then call ps_table_insert (table, pl, n_rad, i, pdg, constraints, & do_not_check_regular = do_not_check_regular) else allocate (pdg_work (size (pdg))) do p = 1, size (pdg) pdg_work(1) = pdg(p) pdg_work(2:p) = pdg(1:p-1) pdg_work(p+1:) = pdg(p+1:) select case (table%proc_type) case (PROC_DECAY) call ps_table_insert (table, & pl, n_rad, i, pdg_work, constraints, n_in = 1, & do_not_check_regular = do_not_check_regular) case (PROC_SCATTER) call ps_table_insert (table, & pl, n_rad, i, pdg_work, constraints, n_in = 2, & do_not_check_regular = do_not_check_regular) end select end do end if end subroutine if_table_insert @ %def if_table_insert @ Sort before recording. In the case of the [[if_table]], we do not sort the first [[n_in]] particle entries. Instead, we check whether they are allowed in the [[pl_beam]] PDG list, if that is provided. <>= procedure :: record_sorted => ps_table_record_sorted <>= procedure :: record_sorted => if_table_record_sorted <>= subroutine ps_table_record_sorted & (table, pl, n_loop, n_rad, constraints, do_not_check_regular, passed) class(ps_table_t), intent(inout) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop, n_rad type(split_constraints_t), intent(in) :: constraints logical, intent(in), optional :: do_not_check_regular logical, intent(out) :: passed call table%record (pl%sort_abs (), n_loop, n_rad, constraints, & do_not_check_regular, passed) end subroutine ps_table_record_sorted subroutine if_table_record_sorted & (table, pl, n_loop, n_rad, constraints, do_not_check_regular, passed) class(if_table_t), intent(inout) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop, n_rad type(split_constraints_t), intent(in) :: constraints logical, intent(in), optional :: do_not_check_regular logical, intent(out) :: passed call table%record (pl%sort_abs (2), n_loop, n_rad, constraints, & do_not_check_regular, passed) end subroutine if_table_record_sorted @ %def ps_table_record_sorted if_table_record_sorted @ Record an entry: insert into the list. Check the ordering and insert it at the correct place, unless it is already there. We record an array only if its mass sum is less than the total available energy. This restriction is removed by setting [[constrained]] to false. <>= procedure :: record => ps_table_record <>= subroutine ps_table_record (table, pl, n_loop, n_rad, constraints, & do_not_check_regular, passed) class(ps_table_t), intent(inout) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop, n_rad type(split_constraints_t), intent(in) :: constraints logical, intent(in), optional :: do_not_check_regular logical, intent(out) :: passed type(ps_entry_t), pointer :: current logical :: needs_check passed = .false. needs_check = .true. if (present (do_not_check_regular)) needs_check = .not. do_not_check_regular if (needs_check .and. .not. pl%is_regular ()) then call msg_warning ("Record ps_table entry: Irregular pdg-list encountered!") return end if call constraints%check_before_record (table, pl, n_loop, passed) if (.not. passed) then return end if current => table%first do while (associated (current)) if (pl == current) then if (n_loop == current%n_loop) return else if (pl < current) then call insert return end if current => current%next end do call insert contains subroutine insert () type(ps_entry_t), pointer :: entry allocate (entry) entry%pdg_list_t = pl entry%n_loop = n_loop entry%n_rad = n_rad if (associated (current)) then if (associated (current%previous)) then current%previous%next => entry entry%previous => current%previous else table%first => entry end if entry%next => current current%previous => entry else if (associated (table%last)) then table%last%next => entry entry%previous => table%last else table%first => entry end if table%last => entry end if end subroutine insert end subroutine ps_table_record @ %def ps_table_record @ \subsection{Tools} Compute the mass sum for a PDG list object, counting the entries with indices between (including) [[n1]] and [[n2]]. Rely on the requirement that if an entry is a PDG array, this array must be degenerate in mass. <>= function mass_sum (pl, n1, n2, model) result (m) type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n1, n2 class(model_data_t), intent(in), target :: model integer, dimension(:), allocatable :: pdg real(default) :: m type(field_data_t), pointer :: prt integer :: i m = 0 do i = n1, n2 pdg = pl%get (i) prt => model%get_field_ptr (pdg(1)) m = m + prt%get_mass () end do end function mass_sum @ %def mass_sum @ Invert a PDG array, replacing particles by antiparticles. This depends on the model. <>= function invert_pdg_array (pa, model) result (pa_inv) type(pdg_array_t), intent(in) :: pa class(model_data_t), intent(in), target :: model type(pdg_array_t) :: pa_inv type(field_data_t), pointer :: prt integer :: i, pdg pa_inv = pa do i = 1, pa_inv%get_length () pdg = pa_inv%get (i) prt => model%get_field_ptr (pdg) if (prt%has_antiparticle ()) call pa_inv%set (i, -pdg) end do end function invert_pdg_array @ %def invert_pdg_array @ \subsection{Access results} Return the number of generated decays. <>= procedure :: get_length => ps_table_get_length <>= function ps_table_get_length (ps_table) result (n) class(ps_table_t), intent(in) :: ps_table integer :: n type(ps_entry_t), pointer :: entry n = 0 entry => ps_table%first do while (associated (entry)) n = n + 1 entry => entry%next end do end function ps_table_get_length @ %def ps_table_get_length @ <>= procedure :: get_emitters => ps_table_get_emitters <>= subroutine ps_table_get_emitters (table, constraints, emitters) class(ps_table_t), intent(in) :: table type(split_constraints_t), intent(in) :: constraints integer, dimension(:), allocatable, intent(out) :: emitters class(pdg_list_t), pointer :: pl integer :: i logical :: passed type(vertex_iterator_t) :: vit integer, dimension(:), allocatable :: pdg1, pdg2 integer :: n_emitters integer, dimension(:), allocatable :: emitters_tmp integer, parameter :: buf0 = 6 n_emitters = 0 pl => table%first allocate (emitters_tmp (buf0)) do i = 1, pl%get_size () call constraints%check_before_split (table, pl, i, passed) if (passed) then pdg1 = pl%get(i) call vit%init (table%model, pdg1, .false.) do call vit%get_next_match(pdg2) if (allocated (pdg2)) then if (n_emitters + 1 > size (emitters_tmp)) & call extend_integer_array (emitters_tmp, 10) emitters_tmp (n_emitters + 1) = pdg1(1) n_emitters = n_emitters + 1 else exit end if end do end if end do allocate (emitters (n_emitters)) emitters = emitters_tmp (1:n_emitters) deallocate (emitters_tmp) end subroutine ps_table_get_emitters @ %def ps_table_get_emitters @ Return an allocated array of decay products (PDG codes). If requested, return also the loop and radiation order count. <>= procedure :: get_pdg_out => ps_table_get_pdg_out <>= subroutine ps_table_get_pdg_out (ps_table, i, pa_out, n_loop, n_rad) class(ps_table_t), intent(in) :: ps_table integer, intent(in) :: i type(pdg_array_t), dimension(:), allocatable, intent(out) :: pa_out integer, intent(out), optional :: n_loop, n_rad type(ps_entry_t), pointer :: entry integer :: n, j n = 0 entry => ps_table%first FIND_ENTRY: do while (associated (entry)) n = n + 1 if (n == i) then allocate (pa_out (entry%get_size ())) do j = 1, entry%get_size () pa_out(j) = entry%get (j) if (present (n_loop)) n_loop = entry%n_loop if (present (n_rad)) n_rad = entry%n_rad end do exit FIND_ENTRY end if entry => entry%next end do FIND_ENTRY end subroutine ps_table_get_pdg_out @ %def ps_table_get_pdg_out @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[auto_components_ut.f90]]>>= <> module auto_components_ut use unit_tests use auto_components_uti <> <> contains <> end module auto_components_ut @ %def auto_components_ut @ <<[[auto_components_uti.f90]]>>= <> module auto_components_uti <> <> use pdg_arrays use model_data use model_testbed, only: prepare_model, cleanup_model use auto_components <> <> contains <> end module auto_components_uti @ %def auto_components_ut @ API: driver for the unit tests below. <>= public :: auto_components_test <>= subroutine auto_components_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine auto_components_test @ %def auto_components_tests @ \subsubsection{Generate Decay Table} Determine all kinematically allowed decay channels for a Higgs boson, using default parameter values. <>= call test (auto_components_1, "auto_components_1", & "generate decay table", & u, results) <>= public :: auto_components_1 <>= subroutine auto_components_1 (u) integer, intent(in) :: u class(model_data_t), pointer :: model type(field_data_t), pointer :: prt type(ds_table_t) :: ds_table type(split_constraints_t) :: constraints write (u, "(A)") "* Test output: auto_components_1" write (u, "(A)") "* Purpose: determine Higgs decay table" write (u, *) write (u, "(A)") "* Read Standard Model" model => null () call prepare_model (model, var_str ("SM")) prt => model%get_field_ptr (25) write (u, *) write (u, "(A)") "* Higgs decays n = 2" write (u, *) call constraints%init (2) call constraints%set (1, constrain_n_tot (2)) call constraints%set (2, constrain_mass_sum (prt%get_mass ())) call ds_table%make (model, 25, constraints) call ds_table%write (u) call ds_table%final () write (u, *) write (u, "(A)") "* Higgs decays n = 3 (w/o radiative)" write (u, *) call constraints%init (3) call constraints%set (1, constrain_n_tot (3)) call constraints%set (2, constrain_mass_sum (prt%get_mass ())) call constraints%set (3, constrain_radiation ()) call ds_table%make (model, 25, constraints) call ds_table%write (u) call ds_table%final () write (u, *) write (u, "(A)") "* Higgs decays n = 3 (w/ radiative)" write (u, *) call constraints%init (2) call constraints%set (1, constrain_n_tot (3)) call constraints%set (2, constrain_mass_sum (prt%get_mass ())) call ds_table%make (model, 25, constraints) call ds_table%write (u) call ds_table%final () write (u, *) write (u, "(A)") "* Cleanup" call cleanup_model (model) deallocate (model) write (u, *) write (u, "(A)") "* Test output end: auto_components_1" end subroutine auto_components_1 @ %def auto_components_1 @ \subsubsection{Generate radiation} Given a final state, add radiation (NLO and NNLO). We provide a list of particles that is allowed to occur in the generated final states. <>= call test (auto_components_2, "auto_components_2", & "generate NLO corrections, final state", & u, results) <>= public :: auto_components_2 <>= subroutine auto_components_2 (u) integer, intent(in) :: u class(model_data_t), pointer :: model type(pdg_list_t), dimension(:), allocatable :: pl, pl_zzh type(pdg_list_t) :: pl_match type(fs_table_t) :: fs_table type(split_constraints_t) :: constraints real(default) :: sqrts integer :: i write (u, "(A)") "* Test output: auto_components_2" write (u, "(A)") "* Purpose: generate radiation (NLO)" write (u, *) write (u, "(A)") "* Read Standard Model" model => null () call prepare_model (model, var_str ("SM")) write (u, *) write (u, "(A)") "* LO final state" write (u, *) allocate (pl (2)) call pl(1)%init (2) call pl(1)%set (1, 1) call pl(1)%set (2, -1) call pl(2)%init (2) call pl(2)%set (1, 21) call pl(2)%set (2, 21) do i = 1, 2 call pl(i)%write (u); write (u, *) end do write (u, *) write (u, "(A)") "* Initialize FS table" write (u, *) call constraints%init (1) call constraints%set (1, constrain_n_tot (3)) call fs_table%init (model, pl, constraints) call fs_table%write (u) write (u, *) write (u, "(A)") "* Generate NLO corrections, unconstrained" write (u, *) call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, & &complete but mass-constrained" write (u, *) sqrts = 50 call constraints%init (2) call constraints%set (1, constrain_n_tot (3)) call constraints%set (2, constrain_mass_sum (sqrts)) call fs_table%init (model, pl, constraints) call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, restricted" write (u, *) call pl_match%init ([1, -1, 21]) call constraints%init (2) call constraints%set (1, constrain_n_tot (3)) call constraints%set (2, constrain_insert (pl_match)) call fs_table%init (model, pl, constraints) call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NNLO corrections, restricted, with one loop" write (u, *) call pl_match%init ([1, -1, 21]) call constraints%init (3) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_n_loop (1)) call constraints%set (3, constrain_insert (pl_match)) call fs_table%init (model, pl, constraints) call fs_table%enable_loops () call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NNLO corrections, restricted, with loops" write (u, *) call constraints%init (2) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_insert (pl_match)) call fs_table%init (model, pl, constraints) call fs_table%enable_loops () call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NNLO corrections, restricted, to Z Z H, & &no loops" write (u, *) allocate (pl_zzh (1)) call pl_zzh(1)%init (3) call pl_zzh(1)%set (1, 23) call pl_zzh(1)%set (2, 23) call pl_zzh(1)%set (3, 25) call constraints%init (3) call constraints%set (1, constrain_n_tot (5)) call constraints%set (2, constrain_mass_sum (500._default)) call constraints%set (3, constrain_require (pl_zzh(1))) call fs_table%init (model, pl_zzh, constraints) call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () call cleanup_model (model) deallocate (model) write (u, *) write (u, "(A)") "* Test output end: auto_components_2" end subroutine auto_components_2 @ %def auto_components_2 @ \subsubsection{Generate radiation from initial and final state} Given a process, add radiation (NLO and NNLO). We provide a list of particles that is allowed to occur in the generated final states. <>= call test (auto_components_3, "auto_components_3", & "generate NLO corrections, in and out", & u, results) <>= public :: auto_components_3 <>= subroutine auto_components_3 (u) integer, intent(in) :: u class(model_data_t), pointer :: model type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out type(pdg_list_t) :: pl_match, pl_beam type(if_table_t) :: if_table type(split_constraints_t) :: constraints real(default) :: sqrts integer :: i write (u, "(A)") "* Test output: auto_components_3" write (u, "(A)") "* Purpose: generate radiation (NLO)" write (u, *) write (u, "(A)") "* Read Standard Model" model => null () call prepare_model (model, var_str ("SM")) write (u, *) write (u, "(A)") "* LO initial state" write (u, *) allocate (pl_in (2)) call pl_in(1)%init (2) call pl_in(1)%set (1, 1) call pl_in(1)%set (2, -1) call pl_in(2)%init (2) call pl_in(2)%set (1, -1) call pl_in(2)%set (2, 1) do i = 1, 2 call pl_in(i)%write (u); write (u, *) end do write (u, *) write (u, "(A)") "* LO final state" write (u, *) allocate (pl_out (1)) call pl_out(1)%init (1) call pl_out(1)%set (1, 23) call pl_out(1)%write (u); write (u, *) write (u, *) write (u, "(A)") "* Initialize FS table" write (u, *) call constraints%init (1) call constraints%set (1, constrain_n_tot (4)) call if_table%init (model, pl_in, pl_out, constraints) call if_table%write (u) write (u, *) write (u, "(A)") "* Generate NLO corrections, unconstrained" write (u, *) call if_table%radiate (constraints) call if_table%write (u) call if_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, & &complete but mass-constrained" write (u, *) sqrts = 100 call constraints%init (2) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_mass_sum (sqrts)) call if_table%init (model, pl_in, pl_out, constraints) call if_table%radiate (constraints) call if_table%write (u) call if_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, & &mass-constrained, restricted beams" write (u, *) call pl_beam%init (3) call pl_beam%set (1, 1) call pl_beam%set (2, -1) call pl_beam%set (3, 21) call constraints%init (3) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_in_state (pl_beam)) call constraints%set (3, constrain_mass_sum (sqrts)) call if_table%init (model, pl_in, pl_out, constraints) call if_table%radiate (constraints) call if_table%write (u) call if_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, restricted" write (u, *) call pl_match%init ([1, -1, 21]) call constraints%init (4) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_in_state (pl_beam)) call constraints%set (3, constrain_mass_sum (sqrts)) call constraints%set (4, constrain_insert (pl_match)) call if_table%init (model, pl_in, pl_out, constraints) call if_table%radiate (constraints) call if_table%write (u) call if_table%final () write (u, *) write (u, "(A)") "* Generate NNLO corrections, restricted, Z preserved, & &with loops" write (u, *) call constraints%init (5) call constraints%set (1, constrain_n_tot (5)) call constraints%set (2, constrain_in_state (pl_beam)) call constraints%set (3, constrain_mass_sum (sqrts)) call constraints%set (4, constrain_insert (pl_match)) call constraints%set (5, constrain_require (pl_out(1))) call if_table%init (model, pl_in, pl_out, constraints) call if_table%enable_loops () call if_table%radiate (constraints) call if_table%write (u) call if_table%final () call cleanup_model (model) deallocate (model) write (u, *) write (u, "(A)") "* Test output end: auto_components_3" end subroutine auto_components_3 @ %def auto_components_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Creating the real flavor structure} <<[[radiation_generator.f90]]>>= <> module radiation_generator <> <> use diagnostics use io_units use physics_defs, only: PHOTON, GLUON use pdg_arrays use flavors use model_data use auto_components use string_utils, only: split_string, string_contains_word implicit none private <> <> contains <> end module radiation_generator @ %def radiation_generator @ <>= type :: pdg_sorter_t integer :: pdg logical :: checked = .false. integer :: associated_born = 0 end type pdg_sorter_t @ %def pdg_sorter @ <>= type :: pdg_states_t type(pdg_array_t), dimension(:), allocatable :: pdg type(pdg_states_t), pointer :: next integer :: n_particles contains <> end type pdg_states_t @ %def pdg_states_t <>= procedure :: init => pdg_states_init <>= subroutine pdg_states_init (states) class(pdg_states_t), intent(inout) :: states nullify (states%next) end subroutine pdg_states_init @ %def pdg_states_init @ <>= procedure :: add => pdg_states_add <>= subroutine pdg_states_add (states, pdg) class(pdg_states_t), intent(inout), target :: states type(pdg_array_t), dimension(:), intent(in) :: pdg type(pdg_states_t), pointer :: current_state select type (states) type is (pdg_states_t) current_state => states do if (associated (current_state%next)) then current_state => current_state%next else allocate (current_state%next) nullify(current_state%next%next) current_state%pdg = pdg exit end if end do end select end subroutine pdg_states_add @ %def pdg_states_add @ <>= procedure :: get_n_states => pdg_states_get_n_states <>= function pdg_states_get_n_states (states) result (n) class(pdg_states_t), intent(in), target :: states integer :: n type(pdg_states_t), pointer :: current_state n = 0 select type(states) type is (pdg_states_t) current_state => states do if (associated (current_state%next)) then n = n+1 current_state => current_state%next else exit end if end do end select end function pdg_states_get_n_states @ %def pdg_states_get_n_states @ <>= type :: prt_queue_t type(string_t), dimension(:), allocatable :: prt_string type(prt_queue_t), pointer :: next => null () type(prt_queue_t), pointer :: previous => null () type(prt_queue_t), pointer :: front => null () type(prt_queue_t), pointer :: current_prt => null () type(prt_queue_t), pointer :: back => null () integer :: n_lists = 0 contains <> end type prt_queue_t @ %def prt_queue_t @ <>= procedure :: null => prt_queue_null <>= subroutine prt_queue_null (queue) class(prt_queue_t), intent(out) :: queue queue%next => null () queue%previous => null () queue%front => null () queue%current_prt => null () queue%back => null () queue%n_lists = 0 if (allocated (queue%prt_string)) deallocate (queue%prt_string) end subroutine prt_queue_null @ %def prt_queue_null @ <>= procedure :: append => prt_queue_append <>= subroutine prt_queue_append (queue, prt_string) class(prt_queue_t), intent(inout) :: queue type(string_t), intent(in), dimension(:) :: prt_string type(prt_queue_t), pointer :: new_element => null () type(prt_queue_t), pointer :: current_back => null () allocate (new_element) allocate (new_element%prt_string(size (prt_string))) new_element%prt_string = prt_string if (associated (queue%back)) then current_back => queue%back current_back%next => new_element new_element%previous => current_back queue%back => new_element else !!! Initial entry queue%front => new_element queue%back => queue%front queue%current_prt => queue%front end if queue%n_lists = queue%n_lists + 1 end subroutine prt_queue_append @ %def prt_queue_append @ <>= procedure :: get => prt_queue_get <>= subroutine prt_queue_get (queue, prt_string) class(prt_queue_t), intent(inout) :: queue type(string_t), dimension(:), allocatable, intent(out) :: prt_string if (associated (queue%current_prt)) then prt_string = queue%current_prt%prt_string if (associated (queue%current_prt%next)) & queue%current_prt => queue%current_prt%next else prt_string = " " end if end subroutine prt_queue_get @ %def prt_queue_get @ As above. <>= procedure :: get_last => prt_queue_get_last <>= subroutine prt_queue_get_last (queue, prt_string) class(prt_queue_t), intent(in) :: queue type(string_t), dimension(:), allocatable, intent(out) :: prt_string if (associated (queue%back)) then allocate (prt_string(size (queue%back%prt_string))) prt_string = queue%back%prt_string else prt_string = " " end if end subroutine prt_queue_get_last @ %def prt_queue_get_last @ <>= procedure :: reset => prt_queue_reset <>= subroutine prt_queue_reset (queue) class(prt_queue_t), intent(inout) :: queue queue%current_prt => queue%front end subroutine prt_queue_reset @ %def prt_queue_reset @ <>= procedure :: check_for_same_prt_strings => prt_queue_check_for_same_prt_strings <>= function prt_queue_check_for_same_prt_strings (queue) result (val) class(prt_queue_t), intent(inout) :: queue logical :: val type(string_t), dimension(:), allocatable :: prt_string integer, dimension(:,:), allocatable :: i_particle integer :: n_d, n_dbar, n_u, n_ubar, n_s, n_sbar, n_gl, n_e, n_ep, n_mu, n_mup, n_A integer :: i, j call queue%reset () allocate (i_particle (queue%n_lists, 12)) do i = 1, queue%n_lists call queue%get (prt_string) n_d = count_particle (prt_string, 1) n_dbar = count_particle (prt_string, -1) n_u = count_particle (prt_string, 2) n_ubar = count_particle (prt_string, -2) n_s = count_particle (prt_string, 3) n_sbar = count_particle (prt_string, -3) n_gl = count_particle (prt_string, 21) n_e = count_particle (prt_string, 11) n_ep = count_particle (prt_string, -11) n_mu = count_particle (prt_string, 13) n_mup = count_particle (prt_string, -13) n_A = count_particle (prt_string, 22) i_particle (i, 1) = n_d i_particle (i, 2) = n_dbar i_particle (i, 3) = n_u i_particle (i, 4) = n_ubar i_particle (i, 5) = n_s i_particle (i, 6) = n_sbar i_particle (i, 7) = n_gl i_particle (i, 8) = n_e i_particle (i, 9) = n_ep i_particle (i, 10) = n_mu i_particle (i, 11) = n_mup i_particle (i, 12) = n_A end do val = .false. do i = 1, queue%n_lists do j = 1, queue%n_lists if (i == j) cycle val = val .or. all (i_particle (i,:) == i_particle(j,:)) end do end do contains function count_particle (prt_string, pdg) result (n) type(string_t), dimension(:), intent(in) :: prt_string integer, intent(in) :: pdg integer :: n integer :: i type(string_t) :: prt_ref n = 0 select case (pdg) case (1) prt_ref = "d" case (-1) prt_ref = "dbar" case (2) prt_ref = "u" case (-2) prt_ref = "ubar" case (3) prt_ref = "s" case (-3) prt_ref = "sbar" case (21) prt_ref = "gl" case (11) prt_ref = "e-" case (-11) prt_ref = "e+" case (13) prt_ref = "mu-" case (-13) prt_ref = "mu+" case (22) prt_ref = "A" end select do i = 1, size (prt_string) if (prt_string(i) == prt_ref) n = n+1 end do end function count_particle end function prt_queue_check_for_same_prt_strings @ %def prt_queue_check_for_same_prt_strings @ <>= procedure :: contains => prt_queue_contains <>= function prt_queue_contains (queue, prt_string) result (val) class(prt_queue_t), intent(in) :: queue type(string_t), intent(in), dimension(:) :: prt_string logical :: val type(prt_queue_t), pointer :: current => null() if (associated (queue%front)) then current => queue%front else call msg_fatal ("Trying to access empty particle queue") end if val = .false. do if (size (current%prt_string) == size (prt_string)) then if (all (current%prt_string == prt_string)) then val = .true. exit end if end if if (associated (current%next)) then current => current%next else exit end if end do end function prt_queue_contains @ %def prt_string_list_contains @ <>= procedure :: write => prt_queue_write <>= subroutine prt_queue_write (queue, unit) class(prt_queue_t), intent(in) :: queue integer, optional :: unit type(prt_queue_t), pointer :: current => null () integer :: i, j, u u = given_output_unit (unit) if (associated (queue%front)) then current => queue%front else write (u, "(A)") "[Particle queue is empty]" return end if j = 1 do write (u, "(I2,A,1X)", advance = 'no') j , ":" do i = 1, size (current%prt_string) write (u, "(A,1X)", advance = 'no') char (current%prt_string(i)) end do write (u, "(A)") if (associated (current%next)) then current => current%next j = j+1 else exit end if end do end subroutine prt_queue_write @ %def prt_queue_write @ <>= subroutine sort_prt (prt, model) type(string_t), dimension(:), intent(inout) :: prt class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(:), allocatable :: pdg type(flavor_t) :: flv integer :: i call create_pdg_array (prt, model, pdg) call sort_pdg (pdg) do i = 1, size (pdg) call flv%init (pdg(i)%get(), model) prt(i) = flv%get_name () end do end subroutine sort_prt subroutine sort_pdg (pdg) type(pdg_array_t), dimension(:), intent(inout) :: pdg integer, dimension(:), allocatable :: i_pdg integer :: i allocate (i_pdg (size (pdg))) do i = 1, size (pdg) i_pdg(i) = pdg(i)%get () end do i_pdg = sort_abs (i_pdg) do i = 1, size (pdg) call pdg(i)%set (1, i_pdg(i)) end do end subroutine sort_pdg subroutine create_pdg_array (prt, model, pdg) type (string_t), dimension(:), intent(in) :: prt class (model_data_t), intent(in), target :: model type(pdg_array_t), dimension(:), allocatable, intent(out) :: pdg type(flavor_t) :: flv integer :: i allocate (pdg (size (prt))) do i = 1, size (prt) call flv%init (prt(i), model) pdg(i) = flv%get_pdg () end do end subroutine create_pdg_array @ %def sort_prt sort_pdg create_pdg_array @ This is used in unit tests: <>= subroutine write_pdg_array (pdg, u) use pdg_arrays type(pdg_array_t), dimension(:), intent(in) :: pdg integer, intent(in) :: u integer :: i do i = 1, size (pdg) call pdg(i)%write (u) end do write (u, "(A)") end subroutine write_pdg_array subroutine write_particle_string (prt, u) <> type(string_t), dimension(:), intent(in) :: prt integer, intent(in) :: u integer :: i do i = 1, size (prt) write (u, "(A,1X)", advance = "no") char (prt(i)) end do write (u, "(A)") end subroutine write_particle_string @ %def write_pdg_array write_particle_string <>= type :: reshuffle_list_t integer, dimension(:), allocatable :: ii type(reshuffle_list_t), pointer :: next => null () contains <> end type reshuffle_list_t @ %def reshuffle_list_t @ <>= procedure :: write => reshuffle_list_write <>= subroutine reshuffle_list_write (rlist) class(reshuffle_list_t), intent(in) :: rlist type(reshuffle_list_t), pointer :: current => null () integer :: i print *, 'Content of reshuffling list: ' if (associated (rlist%next)) then current => rlist%next i = 1 do print *, 'i: ', i, 'list: ', current%ii i = i + 1 if (associated (current%next)) then current => current%next else exit end if end do else print *, '[EMPTY]' end if end subroutine reshuffle_list_write @ %def reshuffle_list_write @ <>= procedure :: append => reshuffle_list_append <>= subroutine reshuffle_list_append (rlist, ii) class(reshuffle_list_t), intent(inout) :: rlist integer, dimension(:), allocatable, intent(in) :: ii type(reshuffle_list_t), pointer :: current if (associated (rlist%next)) then current => rlist%next do if (associated (current%next)) then current => current%next else allocate (current%next) allocate (current%next%ii (size (ii))) current%next%ii = ii exit end if end do else allocate (rlist%next) allocate (rlist%next%ii (size (ii))) rlist%next%ii = ii end if end subroutine reshuffle_list_append @ %def reshuffle_list_append @ <>= procedure :: is_empty => reshuffle_list_is_empty <>= elemental function reshuffle_list_is_empty (rlist) result (is_empty) logical :: is_empty class(reshuffle_list_t), intent(in) :: rlist is_empty = .not. associated (rlist%next) end function reshuffle_list_is_empty @ %def reshuffle_list_is_empty @ <>= procedure :: get => reshuffle_list_get <>= function reshuffle_list_get (rlist, index) result (ii) integer, dimension(:), allocatable :: ii class(reshuffle_list_t), intent(inout) :: rlist integer, intent(in) :: index type(reshuffle_list_t), pointer :: current => null () integer :: i current => rlist%next do i = 1, index - 1 if (associated (current%next)) then current => current%next else call msg_fatal ("Index exceeds size of reshuffling list") end if end do allocate (ii (size (current%ii))) ii = current%ii end function reshuffle_list_get @ %def reshuffle_list_get @ We need to reset the [[reshuffle_list]] in order to deal with subsequent usages of the [[radiation_generator]]. Below is obviously the lazy and dirty solution. Otherwise, we would have to equip this auxiliary type with additional information about [[last]] and [[previous]] pointers. Considering that at most $n_{\rm{legs}}$ integers are saved in the lists, and that the subroutine is only called during the initialization phase (more precisely: at the moment only in the [[radiation_generator]] unit tests), I think this quick fix is justified. <>= procedure :: reset => reshuffle_list_reset <>= subroutine reshuffle_list_reset (rlist) class(reshuffle_list_t), intent(inout) :: rlist rlist%next => null () end subroutine reshuffle_list_reset @ %def reshuffle_list_reset @ <>= public :: radiation_generator_t <>= type :: radiation_generator_t logical :: qcd_enabled = .false. logical :: qed_enabled = .false. logical :: is_gluon = .false. logical :: fs_gluon = .false. logical :: is_photon = .false. logical :: fs_photon = .false. logical :: only_final_state = .true. type(pdg_list_t) :: pl_in, pl_out type(pdg_list_t) :: pl_excluded_gauge_splittings type(split_constraints_t) :: constraints integer :: n_tot integer :: n_in, n_out integer :: n_loops integer :: n_light_quarks real(default) :: mass_sum type(prt_queue_t) :: prt_queue type(pdg_states_t) :: pdg_raw type(pdg_array_t), dimension(:), allocatable :: pdg_in_born, pdg_out_born type(if_table_t) :: if_table type(reshuffle_list_t) :: reshuffle_list contains <> end type radiation_generator_t @ @ %def radiation_generator_t <>= generic :: init => init_pdg_list, init_pdg_array procedure :: init_pdg_list => radiation_generator_init_pdg_list procedure :: init_pdg_array => radiation_generator_init_pdg_array <>= subroutine radiation_generator_init_pdg_list & (generator, pl_in, pl_out, pl_excluded_gauge_splittings, qcd, qed) class(radiation_generator_t), intent(inout) :: generator type(pdg_list_t), intent(in) :: pl_in, pl_out type(pdg_list_t), intent(in) :: pl_excluded_gauge_splittings logical, intent(in), optional :: qcd, qed if (present (qcd)) generator%qcd_enabled = qcd if (present (qed)) generator%qed_enabled = qed generator%pl_in = pl_in generator%pl_out = pl_out generator%pl_excluded_gauge_splittings = pl_excluded_gauge_splittings generator%is_gluon = pl_in%search_for_particle (GLUON) generator%fs_gluon = pl_out%search_for_particle (GLUON) generator%is_photon = pl_in%search_for_particle (PHOTON) generator%fs_photon = pl_out%search_for_particle (PHOTON) generator%mass_sum = 0._default call generator%pdg_raw%init () end subroutine radiation_generator_init_pdg_list subroutine radiation_generator_init_pdg_array & (generator, pdg_in, pdg_out, pdg_excluded_gauge_splittings, qcd, qed) class(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), intent(in), dimension(:) :: pdg_in, pdg_out type(pdg_array_t), intent(in), dimension(:) :: pdg_excluded_gauge_splittings logical, intent(in), optional :: qcd, qed type(pdg_list_t) :: pl_in, pl_out type(pdg_list_t) :: pl_excluded_gauge_splittings integer :: i call pl_in%init(size (pdg_in)) call pl_out%init(size (pdg_out)) do i = 1, size (pdg_in) call pl_in%set (i, pdg_in(i)) end do do i = 1, size (pdg_out) call pl_out%set (i, pdg_out(i)) end do call pl_excluded_gauge_splittings%init(size (pdg_excluded_gauge_splittings)) do i = 1, size (pdg_excluded_gauge_splittings) call pl_excluded_gauge_splittings%set & (i, pdg_excluded_gauge_splittings(i)) end do call generator%init (pl_in, pl_out, pl_excluded_gauge_splittings, qcd, qed) end subroutine radiation_generator_init_pdg_array @ %def radiation_generator_init_pdg_list radiation_generator_init_pdg_array @ <>= procedure :: set_initial_state_emissions => & radiation_generator_set_initial_state_emissions <>= subroutine radiation_generator_set_initial_state_emissions (generator) class(radiation_generator_t), intent(inout) :: generator generator%only_final_state = .false. end subroutine radiation_generator_set_initial_state_emissions @ %def radiation_generator_set_initial_state_emissions @ <>= procedure :: setup_if_table => radiation_generator_setup_if_table <>= subroutine radiation_generator_setup_if_table (generator, model) class(radiation_generator_t), intent(inout) :: generator class(model_data_t), intent(in), target :: model type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out allocate (pl_in(1), pl_out(1)) pl_in(1) = generator%pl_in pl_out(1) = generator%pl_out call generator%if_table%init & (model, pl_in, pl_out, generator%constraints) end subroutine radiation_generator_setup_if_table @ %def radiation_generator_setup_if_table @ <>= generic :: reset_particle_content => reset_particle_content_pdg_array, & reset_particle_content_pdg_list procedure :: reset_particle_content_pdg_list => & radiation_generator_reset_particle_content_pdg_list procedure :: reset_particle_content_pdg_array => & radiation_generator_reset_particle_content_pdg_array <>= subroutine radiation_generator_reset_particle_content_pdg_list (generator, pl) class(radiation_generator_t), intent(inout) :: generator type(pdg_list_t), intent(in) :: pl generator%pl_out = pl generator%fs_gluon = pl%search_for_particle (GLUON) generator%fs_photon = pl%search_for_particle (PHOTON) end subroutine radiation_generator_reset_particle_content_pdg_list subroutine radiation_generator_reset_particle_content_pdg_array (generator, pdg) class(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), intent(in), dimension(:) :: pdg type(pdg_list_t) :: pl integer :: i call pl%init (size (pdg)) do i = 1, size (pdg) call pl%set (i, pdg(i)) end do call generator%reset_particle_content (pl) end subroutine radiation_generator_reset_particle_content_pdg_array @ %def radiation_generator_reset_particle_content @ <>= procedure :: reset_reshuffle_list=> radiation_generator_reset_reshuffle_list <>= subroutine radiation_generator_reset_reshuffle_list (generator) class(radiation_generator_t), intent(inout) :: generator call generator%reshuffle_list%reset () end subroutine radiation_generator_reset_reshuffle_list @ %def radiation_generator_reset_reshuffle_list @ <>= procedure :: set_n => radiation_generator_set_n <>= subroutine radiation_generator_set_n (generator, n_in, n_out, n_loops) class(radiation_generator_t), intent(inout) :: generator integer, intent(in) :: n_in, n_out, n_loops generator%n_tot = n_in + n_out + 1 generator%n_in = n_in generator%n_out = n_out generator%n_loops = n_loops end subroutine radiation_generator_set_n @ %def radiation_generator_set_n @ <>= procedure :: set_constraints => radiation_generator_set_constraints <>= subroutine radiation_generator_set_constraints & (generator, set_n_loop, set_mass_sum, & set_selected_particles, set_required_particles) class(radiation_generator_t), intent(inout), target :: generator logical, intent(in) :: set_n_loop logical, intent(in) :: set_mass_sum logical, intent(in) :: set_selected_particles logical, intent(in) :: set_required_particles logical :: set_no_photon_induced = .true. integer :: i, j, n, n_constraints type(pdg_list_t) :: pl_req, pl_insert type(pdg_list_t) :: pl_antiparticles type(pdg_array_t) :: pdg_gluon, pdg_photon type(pdg_array_t) :: pdg_add, pdg_tmp integer :: last_index integer :: n_new_particles, n_skip integer, dimension(:), allocatable :: i_skip integer :: n_nlo_correction_types n_nlo_correction_types = count ([generator%qcd_enabled, generator%qed_enabled]) if (generator%is_photon) set_no_photon_induced = .false. allocate (i_skip (generator%n_tot)) i_skip = -1 n_constraints = 2 + count([set_n_loop, set_mass_sum, & set_selected_particles, set_required_particles, set_no_photon_induced]) associate (constraints => generator%constraints) n = 1 call constraints%init (n_constraints) call constraints%set (n, constrain_n_tot (generator%n_tot)) n = 2 call constraints%set (n, constrain_couplings (generator%qcd_enabled, & generator%qed_enabled, n_nlo_correction_types)) n = n + 1 if (set_no_photon_induced) then call constraints%set (n, constrain_photon_induced_processes (generator%n_in)) n = n + 1 end if if (set_n_loop) then call constraints%set (n, constrain_n_loop(generator%n_loops)) n = n + 1 end if if (set_mass_sum) then call constraints%set (n, constrain_mass_sum(generator%mass_sum)) n = n + 1 end if if (set_required_particles) then if (generator%fs_gluon .or. generator%fs_photon) then do i = 1, generator%n_out pdg_tmp = generator%pl_out%get(i) if (pdg_tmp%search_for_particle (GLUON) & .or. pdg_tmp%search_for_particle (PHOTON)) then i_skip(i) = i end if end do n_skip = count (i_skip > 0) call pl_req%init (generator%n_out-n_skip) else call pl_req%init (generator%n_out) end if j = 1 do i = 1, generator%n_out if (any (i == i_skip)) cycle call pl_req%set (j, generator%pl_out%get(i)) j = j + 1 end do call constraints%set (n, constrain_require (pl_req)) n = n + 1 end if if (set_selected_particles) then if (generator%only_final_state ) then call pl_insert%init (generator%n_out + n_nlo_correction_types) do i = 1, generator%n_out call pl_insert%set(i, generator%pl_out%get(i)) end do last_index = generator%n_out + 1 else call generator%pl_in%create_antiparticles (pl_antiparticles, n_new_particles) call pl_insert%init (generator%n_tot + n_new_particles & + n_nlo_correction_types) do i = 1, generator%n_in call pl_insert%set(i, generator%pl_in%get(i)) end do do i = 1, generator%n_out j = i + generator%n_in call pl_insert%set(j, generator%pl_out%get(i)) end do do i = 1, n_new_particles j = i + generator%n_in + generator%n_out call pl_insert%set(j, pl_antiparticles%get(i)) end do last_index = generator%n_tot + n_new_particles + 1 end if pdg_gluon = GLUON; pdg_photon = PHOTON if (generator%qcd_enabled) then pdg_add = pdg_gluon call pl_insert%set (last_index, pdg_add) last_index = last_index + 1 end if if (generator%qed_enabled) then pdg_add = pdg_photon call pl_insert%set (last_index, pdg_add) end if call constraints%set (n, constrain_splittings (pl_insert, & generator%pl_excluded_gauge_splittings)) end if end associate end subroutine radiation_generator_set_constraints @ %def radiation_generator_set_constraints @ <>= procedure :: find_splittings => radiation_generator_find_splittings <>= subroutine radiation_generator_find_splittings (generator) class(radiation_generator_t), intent(inout) :: generator integer :: i type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out, pdg_tmp integer, dimension(:), allocatable :: reshuffle_list call generator%pl_in%create_pdg_array (pdg_in) call generator%pl_out%create_pdg_array (pdg_out) associate (if_table => generator%if_table) call if_table%radiate (generator%constraints, do_not_check_regular = .true.) do i = 1, if_table%get_length () call if_table%get_pdg_out (i, pdg_tmp) if (size (pdg_tmp) == generator%n_tot) then call pdg_reshuffle (pdg_out, pdg_tmp, reshuffle_list) call generator%reshuffle_list%append (reshuffle_list) end if end do end associate contains subroutine pdg_reshuffle (pdg_born, pdg_real, list) type(pdg_array_t), intent(in), dimension(:) :: pdg_born, pdg_real integer, intent(out), dimension(:), allocatable :: list type(pdg_sorter_t), dimension(:), allocatable :: sort_born type(pdg_sorter_t), dimension(:), allocatable :: sort_real integer :: i_min, n_in, n_born, n_real integer :: ib, ir n_in = generator%n_in n_born = size (pdg_born) n_real = size (pdg_real) allocate (list (n_real - n_in)) allocate (sort_born (n_born)) allocate (sort_real (n_real - n_in)) sort_born%pdg = pdg_born%get () sort_real%pdg = pdg_real(n_in + 1 : n_real)%get() do ib = 1, n_born if (any (sort_born(ib)%pdg == sort_real%pdg)) & call associate_born_indices (sort_born(ib), sort_real, ib, n_real) end do i_min = maxval (sort_real%associated_born) + 1 do ir = 1, n_real - n_in if (sort_real(ir)%associated_born == 0) then sort_real(ir)%associated_born = i_min i_min = i_min + 1 end if end do list = sort_real%associated_born end subroutine pdg_reshuffle subroutine associate_born_indices (sort_born, sort_real, ib, n_real) type(pdg_sorter_t), intent(in) :: sort_born type(pdg_sorter_t), intent(inout), dimension(:) :: sort_real integer, intent(in) :: ib, n_real integer :: ir do ir = 1, n_real - generator%n_in if (sort_born%pdg == sort_real(ir)%pdg & .and..not. sort_real(ir)%checked) then sort_real(ir)%associated_born = ib sort_real(ir)%checked = .true. exit end if end do end subroutine associate_born_indices end subroutine radiation_generator_find_splittings @ %def radiation_generator_find_splittings @ <>= procedure :: generate_real_particle_strings & => radiation_generator_generate_real_particle_strings <>= subroutine radiation_generator_generate_real_particle_strings & (generator, prt_tot_in, prt_tot_out) type :: prt_array_t type(string_t), dimension(:), allocatable :: prt end type class(radiation_generator_t), intent(inout) :: generator type(string_t), intent(out), dimension(:), allocatable :: prt_tot_in, prt_tot_out type(prt_array_t), dimension(:), allocatable :: prt_in, prt_out type(prt_array_t), dimension(:), allocatable :: prt_out0, prt_in0 type(pdg_array_t), dimension(:), allocatable :: pdg_tmp, pdg_out, pdg_in type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out type(prt_array_t) :: prt_out0_tmp, prt_in0_tmp integer :: i, j integer, dimension(:), allocatable :: reshuffle_list_local type(reshuffle_list_t) :: reshuffle_list integer :: flv type(string_t), dimension(:), allocatable :: buf integer :: i_buf flv = 0 allocate (prt_in0(0), prt_out0(0)) associate (if_table => generator%if_table) do i = 1, if_table%get_length () call if_table%get_pdg_out (i, pdg_tmp) if (size (pdg_tmp) == generator%n_tot) then call if_table%get_particle_string (i, & prt_in0_tmp%prt, prt_out0_tmp%prt) prt_in0 = [prt_in0, prt_in0_tmp] prt_out0 = [prt_out0, prt_out0_tmp] flv = flv + 1 end if end do end associate allocate (prt_in(size (prt_in0)), prt_out(size (prt_out0))) do i = 1, flv allocate (prt_in(i)%prt (generator%n_in)) allocate (prt_out(i)%prt (generator%n_tot - generator%n_in)) end do allocate (prt_tot_in (generator%n_in)) allocate (prt_tot_out (generator%n_tot - generator%n_in)) allocate (buf (generator%n_tot)) buf = "" do j = 1, flv do i = 1, generator%n_in prt_in(j)%prt(i) = prt_in0(j)%prt(i) call fill_buffer (buf(i), prt_in0(j)%prt(i)) end do end do prt_tot_in = buf(1 : generator%n_in) do j = 1, flv allocate (reshuffle_list_local (size (generator%reshuffle_list%get(j)))) reshuffle_list_local = generator%reshuffle_list%get(j) do i = 1, size (reshuffle_list_local) prt_out(j)%prt(reshuffle_list_local(i)) = prt_out0(j)%prt(i) i_buf = reshuffle_list_local(i) + generator%n_in call fill_buffer (buf(i_buf), & prt_out(j)%prt(reshuffle_list_local(i))) end do !!! Need to deallocate here because in the next iteration the reshuffling !!! list can have a different size deallocate (reshuffle_list_local) end do prt_tot_out = buf(generator%n_in + 1 : generator%n_tot) if (debug2_active (D_CORE)) then print *, 'Generated initial state: ' do i = 1, size (prt_tot_in) print *, char (prt_tot_in(i)) end do print *, 'Generated final state: ' do i = 1, size (prt_tot_out) print *, char (prt_tot_out(i)) end do end if contains subroutine fill_buffer (buffer, particle) type(string_t), intent(inout) :: buffer type(string_t), intent(in) :: particle logical :: particle_present if (len (buffer) > 0) then particle_present = check_for_substring (char(buffer), particle) if (.not. particle_present) buffer = buffer // ":" // particle else buffer = buffer // particle end if end subroutine fill_buffer function check_for_substring (buffer, substring) result (exist) character(len=*), intent(in) :: buffer type(string_t), intent(in) :: substring character(len=50) :: buffer_internal logical :: exist integer :: i_first, i_last exist = .false. i_first = 1; i_last = 1 do if (buffer(i_last:i_last) == ":") then buffer_internal = buffer (i_first : i_last - 1) if (buffer_internal == char (substring)) then exist = .true. exit end if i_first = i_last + 1; i_last = i_first + 1 if (i_last > len(buffer)) exit else if (i_last == len(buffer)) then buffer_internal = buffer (i_first : i_last) exist = buffer_internal == char (substring) exit else i_last = i_last + 1 if (i_last > len(buffer)) exit end if end do end function check_for_substring end subroutine radiation_generator_generate_real_particle_strings @ %def radiation_generator_generate_real_particle_strings @ <>= procedure :: contains_emissions => radiation_generator_contains_emissions <>= function radiation_generator_contains_emissions (generator) result (has_em) logical :: has_em class(radiation_generator_t), intent(in) :: generator has_em = .not. generator%reshuffle_list%is_empty () end function radiation_generator_contains_emissions @ %def radiation_generator_contains_emissions @ <>= procedure :: generate => radiation_generator_generate <>= subroutine radiation_generator_generate (generator, prt_in, prt_out) class(radiation_generator_t), intent(inout) :: generator type(string_t), intent(out), dimension(:), allocatable :: prt_in, prt_out call generator%find_splittings () call generator%generate_real_particle_strings (prt_in, prt_out) end subroutine radiation_generator_generate @ %def radiation_generator_generate @ <>= procedure :: generate_multiple => radiation_generator_generate_multiple <>= subroutine radiation_generator_generate_multiple (generator, max_multiplicity, model) class(radiation_generator_t), intent(inout) :: generator integer, intent(in) :: max_multiplicity class(model_data_t), intent(in), target :: model if (max_multiplicity <= generator%n_out) & call msg_fatal ("GKS states: Multiplicity is not large enough!") call generator%first_emission (model) call generator%reset_reshuffle_list () if (max_multiplicity - generator%n_out > 1) & call generator%append_emissions (max_multiplicity, model) end subroutine radiation_generator_generate_multiple @ %def radiation_generator_generate_multiple @ <>= procedure :: first_emission => radiation_generator_first_emission <>= subroutine radiation_generator_first_emission (generator, model) class(radiation_generator_t), intent(inout) :: generator class(model_data_t), intent(in), target :: model type(string_t), dimension(:), allocatable :: prt_in, prt_out call generator%setup_if_table (model) call generator%generate (prt_in, prt_out) call generator%prt_queue%null () call generator%prt_queue%append (prt_out) end subroutine radiation_generator_first_emission @ %def radiation_generator_first_emission @ <>= procedure :: append_emissions => radiation_generator_append_emissions <>= subroutine radiation_generator_append_emissions (generator, max_multiplicity, model) class(radiation_generator_t), intent(inout) :: generator integer, intent(in) :: max_multiplicity class(model_data_t), intent(in), target :: model type(string_t), dimension(:), allocatable :: prt_fetched type(string_t), dimension(:), allocatable :: prt_in type(string_t), dimension(:), allocatable :: prt_out type(pdg_array_t), dimension(:), allocatable :: pdg_new_out integer :: current_multiplicity, i, j, n_longest_length type :: prt_table_t type(string_t), dimension(:), allocatable :: prt end type prt_table_t type(prt_table_t), dimension(:), allocatable :: prt_table_out do call generator%prt_queue%get (prt_fetched) current_multiplicity = size (prt_fetched) if (current_multiplicity == max_multiplicity) exit call create_pdg_array (prt_fetched, model, & pdg_new_out) call generator%reset_particle_content (pdg_new_out) call generator%set_n (2, current_multiplicity, 0) call generator%set_constraints (.false., .false., .true., .true.) call generator%setup_if_table (model) call generator%generate (prt_in, prt_out) n_longest_length = get_length_of_longest_tuple (prt_out) call separate_particles (prt_out, prt_table_out) do i = 1, n_longest_length if (.not. any (prt_table_out(i)%prt == " ")) then call sort_prt (prt_table_out(i)%prt, model) if (.not. generator%prt_queue%contains (prt_table_out(i)%prt)) then call generator%prt_queue%append (prt_table_out(i)%prt) end if end if end do call generator%reset_reshuffle_list () end do contains subroutine separate_particles (prt, prt_table) type(string_t), intent(in), dimension(:) :: prt type(string_t), dimension(:), allocatable :: prt_tmp type(prt_table_t), intent(out), dimension(:), allocatable :: prt_table integer :: i, j logical, dimension(:), allocatable :: tuples_occured allocate (prt_table (n_longest_length)) do i = 1, n_longest_length allocate (prt_table(i)%prt (size (prt))) end do allocate (tuples_occured (size (prt))) do j = 1, size (prt) call split_string (prt(j), var_str (":"), prt_tmp) do i = 1, n_longest_length if (i <= size (prt_tmp)) then prt_table(i)%prt(j) = prt_tmp(i) else prt_table(i)%prt(j) = " " end if end do if (n_longest_length > 1) & tuples_occured(j) = prt_table(1)%prt(j) /= " " & .and. prt_table(2)%prt(j) /= " " end do if (any (tuples_occured)) then do j = 1, size (tuples_occured) if (.not. tuples_occured(j)) then do i = 2, n_longest_length prt_table(i)%prt(j) = prt_table(1)%prt(j) end do end if end do end if end subroutine separate_particles function get_length_of_longest_tuple (prt) result (longest_length) type(string_t), intent(in), dimension(:) :: prt integer :: longest_length, i type(prt_table_t), dimension(:), allocatable :: prt_table allocate (prt_table (size (prt))) longest_length = 0 do i = 1, size (prt) call split_string (prt(i), var_str (":"), prt_table(i)%prt) if (size (prt_table(i)%prt) > longest_length) & longest_length = size (prt_table(i)%prt) end do end function get_length_of_longest_tuple end subroutine radiation_generator_append_emissions @ %def radiation_generator_append_emissions @ <>= procedure :: reset_queue => radiation_generator_reset_queue <>= subroutine radiation_generator_reset_queue (generator) class(radiation_generator_t), intent(inout) :: generator call generator%prt_queue%reset () end subroutine radiation_generator_reset_queue @ %def radiation_generator_reset_queue @ <>= procedure :: get_n_gks_states => radiation_generator_get_n_gks_states <>= function radiation_generator_get_n_gks_states (generator) result (n) class(radiation_generator_t), intent(in) :: generator integer :: n n = generator%prt_queue%n_lists end function radiation_generator_get_n_gks_states @ %def radiation_generator_get_n_fks_states @ <>= procedure :: get_next_state => radiation_generator_get_next_state <>= function radiation_generator_get_next_state (generator) result (prt_string) class(radiation_generator_t), intent(inout) :: generator type(string_t), dimension(:), allocatable :: prt_string call generator%prt_queue%get (prt_string) end function radiation_generator_get_next_state @ %def radiation_generator_get_next_state @ <>= procedure :: get_emitter_indices => radiation_generator_get_emitter_indices <>= subroutine radiation_generator_get_emitter_indices (generator, indices) class(radiation_generator_t), intent(in) :: generator integer, dimension(:), allocatable, intent(out) :: indices type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out integer, dimension(:), allocatable :: flv_in, flv_out integer, dimension(:), allocatable :: emitters integer :: i, j integer :: n_in, n_out call generator%pl_in%create_pdg_array (pdg_in) call generator%pl_out%create_pdg_array (pdg_out) n_in = size (pdg_in); n_out = size (pdg_out) allocate (flv_in (n_in), flv_out (n_out)) forall (i=1:n_in) flv_in(i) = pdg_in(i)%get() forall (i=1:n_out) flv_out(i) = pdg_out(i)%get() call generator%if_table%get_emitters (generator%constraints, emitters) allocate (indices (size (emitters))) j = 1 do i = 1, n_in + n_out if (i <= n_in) then if (any (flv_in(i) == emitters)) then indices (j) = i j = j + 1 end if else if (any (flv_out(i-n_in) == emitters)) then indices (j) = i j = j + 1 end if end if end do end subroutine radiation_generator_get_emitter_indices @ %def radiation_generator_get_emitter_indices @ <>= procedure :: get_raw_states => radiation_generator_get_raw_states <>= function radiation_generator_get_raw_states (generator) result (raw_states) class(radiation_generator_t), intent(in), target :: generator integer, dimension(:,:), allocatable :: raw_states type(pdg_states_t), pointer :: state integer :: n_states, n_particles integer :: i_state integer :: j state => generator%pdg_raw n_states = generator%pdg_raw%get_n_states () n_particles = size (generator%pdg_raw%pdg) allocate (raw_states (n_particles, n_states)) do i_state = 1, n_states do j = 1, n_particles raw_states (j, i_state) = state%pdg(j)%get () end do state => state%next end do end function radiation_generator_get_raw_states @ %def radiation_generator_get_raw_states @ <>= procedure :: save_born_raw => radiation_generator_save_born_raw <>= subroutine radiation_generator_save_born_raw (generator, pdg_in, pdg_out) class(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), dimension(:), allocatable, intent(in) :: pdg_in, pdg_out generator%pdg_in_born = pdg_in generator%pdg_out_born = pdg_out end subroutine radiation_generator_save_born_raw @ %def radiation_generator_save_born_raw @ <>= procedure :: get_born_raw => radiation_generator_get_born_raw <>= function radiation_generator_get_born_raw (generator) result (flv_born) class(radiation_generator_t), intent(in) :: generator integer, dimension(:,:), allocatable :: flv_born integer :: i_part, n_particles n_particles = size (generator%pdg_in_born) + size (generator%pdg_out_born) allocate (flv_born (n_particles, 1)) flv_born(1,1) = generator%pdg_in_born(1)%get () flv_born(2,1) = generator%pdg_in_born(2)%get () do i_part = 3, n_particles flv_born(i_part, 1) = generator%pdg_out_born(i_part-2)%get () end do end function radiation_generator_get_born_raw @ %def radiation_generator_get_born_raw @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[radiation_generator_ut.f90]]>>= <> module radiation_generator_ut use unit_tests use radiation_generator_uti <> <> contains <> end module radiation_generator_ut @ %def radiation_generator_ut @ <<[[radiation_generator_uti.f90]]>>= <> module radiation_generator_uti <> use format_utils, only: write_separator use os_interface use pdg_arrays use models use kinds, only: default use radiation_generator <> <> contains <> <> end module radiation_generator_uti @ %def radiation_generator_ut @ API: driver for the unit tests below. <>= public :: radiation_generator_test <>= subroutine radiation_generator_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results call test(radiation_generator_1, "radiation_generator_1", & "Test the generator of N+1-particle flavor structures in QCD", & u, results) call test(radiation_generator_2, "radiation_generator_2", & "Test multiple splittings in QCD", & u, results) call test(radiation_generator_3, "radiation_generator_3", & "Test the generator of N+1-particle flavor structures in QED", & u, results) call test(radiation_generator_4, "radiation_generator_4", & "Test multiple splittings in QED", & u, results) end subroutine radiation_generator_test @ %def radiation_generator_test @ <>= public :: radiation_generator_1 <>= subroutine radiation_generator_1 (u) integer, intent(in) :: u type(radiation_generator_t) :: generator type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () write (u, "(A)") "* Test output: radiation_generator_1" write (u, "(A)") "* Purpose: Create N+1-particle flavor structures & &from predefined N-particle flavor structures" write (u, "(A)") "* One additional strong coupling, no additional electroweak coupling" write (u, "(A)") write (u, "(A)") "* Loading radiation model: SM.mdl" call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Success" allocate (pdg_in (2)) pdg_in(1) = 11; pdg_in(2) = -11 write (u, "(A)") "* Start checking processes" call write_separator (u) write (u, "(A)") "* Process 1: Top pair-production with additional gluon" allocate (pdg_out(3)) pdg_out(1) = 6; pdg_out(2) = -6; pdg_out(3) = 21 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 2: Top pair-production with additional jet" allocate (pdg_out(3)) pdg_out(1) = 6; pdg_out(2) = -6; pdg_out(3) = [-1,1,-2,2,-3,3,-4,4,-5,5,21] call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 3: Quark-antiquark production" allocate (pdg_out(2)) pdg_out(1) = 2; pdg_out(2) = -2 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 4: Quark-antiquark production with additional gluon" allocate (pdg_out(3)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 21 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 5: Z + jets" allocate (pdg_out(3)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 23 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 6: Top Decay" allocate (pdg_out(4)) pdg_out(1) = 24; pdg_out(2) = -24 pdg_out(3) = 5; pdg_out(4) = -5 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 7: Production of four quarks" allocate (pdg_out(4)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 2; pdg_out(4) = -2 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 8: Drell-Yan lepto-production" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = 2; pdg_in(2) = -2 pdg_out(1) = 11; pdg_out(2) = -11 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 9: WZ production at hadron-colliders" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = 1; pdg_in(2) = -2 pdg_out(1) = -24; pdg_out(2) = 23 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) contains subroutine test_process (generator, pdg_in, pdg_out, u, include_initial_state) type(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out integer, intent(in) :: u logical, intent(in), optional :: include_initial_state type(string_t), dimension(:), allocatable :: prt_strings_in type(string_t), dimension(:), allocatable :: prt_strings_out type(pdg_array_t), dimension(10) :: pdg_excluded logical :: yorn yorn = .false. pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15] if (present (include_initial_state)) yorn = include_initial_state write (u, "(A)") "* Leading order: " write (u, "(A)", advance = 'no') '* Incoming: ' call write_pdg_array (pdg_in, u) write (u, "(A)", advance = 'no') '* Outgoing: ' call write_pdg_array (pdg_out, u) call generator%init (pdg_in, pdg_out, & pdg_excluded_gauge_splittings = pdg_excluded, qcd = .true., qed = .false.) call generator%set_n (2, size(pdg_out), 0) if (yorn) call generator%set_initial_state_emissions () call generator%set_constraints (.false., .false., .true., .true.) call generator%setup_if_table (model) call generator%generate (prt_strings_in, prt_strings_out) write (u, "(A)") "* Additional radiation: " write (u, "(A)") "* Incoming: " call write_particle_string (prt_strings_in, u) write (u, "(A)") "* Outgoing: " call write_particle_string (prt_strings_out, u) call write_separator(u) call generator%reset_reshuffle_list () end subroutine test_process end subroutine radiation_generator_1 @ %def radiation_generator_1 @ <>= public :: radiation_generator_2 <>= subroutine radiation_generator_2 (u) integer, intent(in) :: u type(radiation_generator_t) :: generator type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out type(pdg_array_t), dimension(:), allocatable :: pdg_excluded type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () integer, parameter :: max_multiplicity = 10 type(string_t), dimension(:), allocatable :: prt_last write (u, "(A)") "* Test output: radiation_generator_2" write (u, "(A)") "* Purpose: Test the repeated application of & &a radiation generator splitting in QCD" write (u, "(A)") "* Only Final state emissions! " write (u, "(A)") write (u, "(A)") "* Loading radiation model: SM.mdl" call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Success" allocate (pdg_in (2)) pdg_in(1) = 11; pdg_in(2) = -11 allocate (pdg_out(2)) pdg_out(1) = 2; pdg_out(2) = -2 allocate (pdg_excluded (10)) pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15] write (u, "(A)") "* Leading order" write (u, "(A)", advance = 'no') "* Incoming: " call write_pdg_array (pdg_in, u) write (u, "(A)", advance = 'no') "* Outgoing: " call write_pdg_array (pdg_out, u) call generator%init (pdg_in, pdg_out, & pdg_excluded_gauge_splittings = pdg_excluded, qcd = .true., qed = .false.) call generator%set_n (2, 2, 0) call generator%set_constraints (.false., .false., .true., .true.) call write_separator (u) write (u, "(A)") "Generate higher-multiplicity states" write (u, "(A,I0)") "Desired multiplicity: ", max_multiplicity call generator%generate_multiple (max_multiplicity, model) call generator%prt_queue%write (u) call write_separator (u) write (u, "(A,I0)") "Number of higher-multiplicity states: ", generator%prt_queue%n_lists write (u, "(A)") "Check that no particle state occurs twice or more" if (.not. generator%prt_queue%check_for_same_prt_strings()) then write (u, "(A)") "SUCCESS" else write (u, "(A)") "FAIL" end if call write_separator (u) write (u, "(A,I0,A)") "Check that there are ", max_multiplicity, " particles in the last entry:" call generator%prt_queue%get_last (prt_last) if (size (prt_last) == max_multiplicity) then write (u, "(A)") "SUCCESS" else write (u, "(A)") "FAIL" end if end subroutine radiation_generator_2 @ %def radiation_generator_2 @ <>= public :: radiation_generator_3 <>= subroutine radiation_generator_3 (u) integer, intent(in) :: u type(radiation_generator_t) :: generator type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () write (u, "(A)") "* Test output: radiation_generator_3" write (u, "(A)") "* Purpose: Create N+1-particle flavor structures & &from predefined N-particle flavor structures" write (u, "(A)") "* One additional electroweak coupling, no additional strong coupling" write (u, "(A)") write (u, "(A)") "* Loading radiation model: SM.mdl" call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Success" allocate (pdg_in (2)) pdg_in(1) = 11; pdg_in(2) = -11 write (u, "(A)") "* Start checking processes" call write_separator (u) write (u, "(A)") "* Process 1: Tau pair-production with additional photon" allocate (pdg_out(3)) pdg_out(1) = 15; pdg_out(2) = -15; pdg_out(3) = 22 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 2: Tau pair-production with additional leptons or photon" allocate (pdg_out(3)) pdg_out(1) = 15; pdg_out(2) = -15; pdg_out(3) = [-13, 13, 22] call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 3: Electron-positron production" allocate (pdg_out(2)) pdg_out(1) = 11; pdg_out(2) = -11 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 4: Quark-antiquark production with additional photon" allocate (pdg_out(3)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 22 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 5: Z + jets " allocate (pdg_out(3)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 23 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 6: W + jets" allocate (pdg_out(3)) pdg_out(1) = 1; pdg_out(2) = -2; pdg_out(3) = -24 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 7: Top Decay" allocate (pdg_out(4)) pdg_out(1) = 24; pdg_out(2) = -24 pdg_out(3) = 5; pdg_out(4) = -5 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 8: Production of four quarks" allocate (pdg_out(4)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 2; pdg_out(4) = -2 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 9: Neutrino pair-production" allocate (pdg_out(2)) pdg_out(1) = 12; pdg_out(2) = -12 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 10: Drell-Yan lepto-production" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = 2; pdg_in(2) = -2 pdg_out(1) = 11; pdg_out(2) = -11 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 11: WZ production at hadron-colliders" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = 1; pdg_in(2) = -2 pdg_out(1) = -24; pdg_out(2) = 23 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 12: Positron-neutrino production" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = -1; pdg_in(2) = 2 pdg_out(1) = -11; pdg_out(2) = 12 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out); deallocate (pdg_in) contains subroutine test_process (generator, pdg_in, pdg_out, u, include_initial_state) type(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out integer, intent(in) :: u logical, intent(in), optional :: include_initial_state type(string_t), dimension(:), allocatable :: prt_strings_in type(string_t), dimension(:), allocatable :: prt_strings_out type(pdg_array_t), dimension(10) :: pdg_excluded logical :: yorn yorn = .false. pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15] if (present (include_initial_state)) yorn = include_initial_state write (u, "(A)") "* Leading order: " write (u, "(A)", advance = 'no') '* Incoming: ' call write_pdg_array (pdg_in, u) write (u, "(A)", advance = 'no') '* Outgoing: ' call write_pdg_array (pdg_out, u) call generator%init (pdg_in, pdg_out, & pdg_excluded_gauge_splittings = pdg_excluded, qcd = .false., qed = .true.) call generator%set_n (2, size(pdg_out), 0) if (yorn) call generator%set_initial_state_emissions () call generator%set_constraints (.false., .false., .true., .true.) call generator%setup_if_table (model) call generator%generate (prt_strings_in, prt_strings_out) write (u, "(A)") "* Additional radiation: " write (u, "(A)") "* Incoming: " call write_particle_string (prt_strings_in, u) write (u, "(A)") "* Outgoing: " call write_particle_string (prt_strings_out, u) call write_separator(u) call generator%reset_reshuffle_list () end subroutine test_process end subroutine radiation_generator_3 @ %def radiation_generator_3 @ <>= public :: radiation_generator_4 <>= subroutine radiation_generator_4 (u) integer, intent(in) :: u type(radiation_generator_t) :: generator type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out type(pdg_array_t), dimension(:), allocatable :: pdg_excluded type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () integer, parameter :: max_multiplicity = 10 type(string_t), dimension(:), allocatable :: prt_last write (u, "(A)") "* Test output: radiation_generator_4" write (u, "(A)") "* Purpose: Test the repeated application of & &a radiation generator splitting in QED" write (u, "(A)") "* Only Final state emissions! " write (u, "(A)") write (u, "(A)") "* Loading radiation model: SM.mdl" call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Success" allocate (pdg_in (2)) pdg_in(1) = 2; pdg_in(2) = -2 allocate (pdg_out(2)) pdg_out(1) = 11; pdg_out(2) = -11 allocate ( pdg_excluded (14)) pdg_excluded = [1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, -6, 15, -15] write (u, "(A)") "* Leading order" write (u, "(A)", advance = 'no') "* Incoming: " call write_pdg_array (pdg_in, u) write (u, "(A)", advance = 'no') "* Outgoing: " call write_pdg_array (pdg_out, u) call generator%init (pdg_in, pdg_out, & pdg_excluded_gauge_splittings = pdg_excluded, qcd = .false., qed = .true.) call generator%set_n (2, 2, 0) call generator%set_constraints (.false., .false., .true., .true.) call write_separator (u) write (u, "(A)") "Generate higher-multiplicity states" write (u, "(A,I0)") "Desired multiplicity: ", max_multiplicity call generator%generate_multiple (max_multiplicity, model) call generator%prt_queue%write (u) call write_separator (u) write (u, "(A,I0)") "Number of higher-multiplicity states: ", generator%prt_queue%n_lists write (u, "(A)") "Check that no particle state occurs twice or more" if (.not. generator%prt_queue%check_for_same_prt_strings()) then write (u, "(A)") "SUCCESS" else write (u, "(A)") "FAIL" end if call write_separator (u) write (u, "(A,I0,A)") "Check that there are ", max_multiplicity, " particles in the last entry:" call generator%prt_queue%get_last (prt_last) if (size (prt_last) == max_multiplicity) then write (u, "(A)") "SUCCESS" else write (u, "(A)") "FAIL" end if end subroutine radiation_generator_4 @ %def radiation_generator_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Sindarin Expression Implementation} This module defines expressions of all kinds, represented in a tree structure, for repeated evaluation. This provides an implementation of the [[expr_base]] abstract type. We have two flavors of expressions: one with particles and one without particles. The latter version is used for defining cut/selection criteria and for online analysis. <<[[eval_trees.f90]]>>= <> module eval_trees use, intrinsic :: iso_c_binding !NODEP! <> <> use io_units use constants, only: DEGREE, IMAGO, PI use format_defs, only: FMT_19 use numeric_utils, only: nearly_equal use diagnostics use lorentz use md5 use formats use sorting use ifiles use lexers use syntax_rules use parser use analysis use jets use pdg_arrays use subevents use var_base use expr_base use variables use observables <> <> <> <> <> contains <> end module eval_trees @ %def eval_trees @ \subsection{Tree nodes} The evaluation tree consists of branch nodes (unary and binary) and of leaf nodes, originating from a common root. The node object should be polymorphic. For the time being, polymorphism is emulated here. This means that we have to maintain all possibilities that the node may hold, including associated procedures as pointers. The following parameter values characterize the node. Unary and binary operators have sub-nodes. The other are leaf nodes. Possible leafs are literal constants or named-parameter references. <>= integer, parameter :: EN_UNKNOWN = 0, EN_UNARY = 1, EN_BINARY = 2 integer, parameter :: EN_CONSTANT = 3, EN_VARIABLE = 4 integer, parameter :: EN_CONDITIONAL = 5, EN_BLOCK = 6 integer, parameter :: EN_RECORD_CMD = 7 integer, parameter :: EN_OBS1_INT = 11, EN_OBS2_INT = 12 integer, parameter :: EN_OBS1_REAL = 21, EN_OBS2_REAL = 22 integer, parameter :: EN_PRT_FUN_UNARY = 101, EN_PRT_FUN_BINARY = 102 integer, parameter :: EN_EVAL_FUN_UNARY = 111, EN_EVAL_FUN_BINARY = 112 integer, parameter :: EN_LOG_FUN_UNARY = 121, EN_LOG_FUN_BINARY = 122 integer, parameter :: EN_INT_FUN_UNARY = 131, EN_INT_FUN_BINARY = 132 integer, parameter :: EN_REAL_FUN_UNARY = 141, EN_REAL_FUN_BINARY = 142 integer, parameter :: EN_FORMAT_STR = 161 @ %def EN_UNKNOWN EN_UNARY EN_BINARY EN_CONSTANT EN_VARIABLE EN_CONDITIONAL @ %def EN_RECORD_CMD @ %def EN_OBS1_INT EN_OBS2_INT EN_OBS1_REAL EN_OBS2_REAL @ %def EN_PRT_FUN_UNARY EN_PRT_FUN_BINARY @ %def EN_EVAL_FUN_UNARY EN_EVAL_FUN_BINARY @ %def EN_LOG_FUN_UNARY EN_LOG_FUN_BINARY @ %def EN_INT_FUN_UNARY EN_INT_FUN_BINARY @ %def EN_REAL_FUN_UNARY EN_REAL_FUN_BINARY @ %def EN_FORMAT_STR @ This is exported only for use within unit tests. <>= public :: eval_node_t <>= type :: eval_node_t private type(string_t) :: tag integer :: type = EN_UNKNOWN integer :: result_type = V_NONE type(var_list_t), pointer :: var_list => null () type(string_t) :: var_name logical, pointer :: value_is_known => null () logical, pointer :: lval => null () integer, pointer :: ival => null () real(default), pointer :: rval => null () complex(default), pointer :: cval => null () type(subevt_t), pointer :: pval => null () type(pdg_array_t), pointer :: aval => null () type(string_t), pointer :: sval => null () type(eval_node_t), pointer :: arg0 => null () type(eval_node_t), pointer :: arg1 => null () type(eval_node_t), pointer :: arg2 => null () type(eval_node_t), pointer :: arg3 => null () type(eval_node_t), pointer :: arg4 => null () procedure(obs_unary_int), nopass, pointer :: obs1_int => null () procedure(obs_unary_real), nopass, pointer :: obs1_real => null () procedure(obs_binary_int), nopass, pointer :: obs2_int => null () procedure(obs_binary_real), nopass, pointer :: obs2_real => null () integer, pointer :: prt_type => null () integer, pointer :: index => null () real(default), pointer :: tolerance => null () integer, pointer :: jet_algorithm => null () real(default), pointer :: jet_r => null () real(default), pointer :: jet_p => null () real(default), pointer :: jet_ycut => null () real(default), pointer :: jet_dcut => null () real(default), pointer :: photon_iso_eps => null () real(default), pointer :: photon_iso_n => null () real(default), pointer :: photon_iso_r0 => null () type(prt_t), pointer :: prt1 => null () type(prt_t), pointer :: prt2 => null () procedure(unary_log), nopass, pointer :: op1_log => null () procedure(unary_int), nopass, pointer :: op1_int => null () procedure(unary_real), nopass, pointer :: op1_real => null () procedure(unary_cmplx), nopass, pointer :: op1_cmplx => null () procedure(unary_pdg), nopass, pointer :: op1_pdg => null () procedure(unary_sev), nopass, pointer :: op1_sev => null () procedure(unary_str), nopass, pointer :: op1_str => null () procedure(unary_cut), nopass, pointer :: op1_cut => null () procedure(unary_evi), nopass, pointer :: op1_evi => null () procedure(unary_evr), nopass, pointer :: op1_evr => null () procedure(binary_log), nopass, pointer :: op2_log => null () procedure(binary_int), nopass, pointer :: op2_int => null () procedure(binary_real), nopass, pointer :: op2_real => null () procedure(binary_cmplx), nopass, pointer :: op2_cmplx => null () procedure(binary_pdg), nopass, pointer :: op2_pdg => null () procedure(binary_sev), nopass, pointer :: op2_sev => null () procedure(binary_str), nopass, pointer :: op2_str => null () procedure(binary_cut), nopass, pointer :: op2_cut => null () procedure(binary_evi), nopass, pointer :: op2_evi => null () procedure(binary_evr), nopass, pointer :: op2_evr => null () contains <> end type eval_node_t @ %def eval_node_t @ Finalize a node recursively. Allocated constants are deleted, pointers are ignored. <>= procedure :: final_rec => eval_node_final_rec <>= recursive subroutine eval_node_final_rec (node) class(eval_node_t), intent(inout) :: node select case (node%type) case (EN_UNARY) call eval_node_final_rec (node%arg1) case (EN_BINARY) call eval_node_final_rec (node%arg1) call eval_node_final_rec (node%arg2) case (EN_CONDITIONAL) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) call eval_node_final_rec (node%arg2) case (EN_BLOCK) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) case (EN_PRT_FUN_UNARY, EN_EVAL_FUN_UNARY, & EN_LOG_FUN_UNARY, EN_INT_FUN_UNARY, EN_REAL_FUN_UNARY) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) deallocate (node%index) deallocate (node%prt1) case (EN_PRT_FUN_BINARY, EN_EVAL_FUN_BINARY, & EN_LOG_FUN_BINARY, EN_INT_FUN_BINARY, EN_REAL_FUN_BINARY) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) call eval_node_final_rec (node%arg2) deallocate (node%index) deallocate (node%prt1) deallocate (node%prt2) case (EN_FORMAT_STR) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) if (associated (node%arg1)) call eval_node_final_rec (node%arg1) deallocate (node%ival) case (EN_RECORD_CMD) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) if (associated (node%arg1)) call eval_node_final_rec (node%arg1) if (associated (node%arg2)) call eval_node_final_rec (node%arg2) if (associated (node%arg3)) call eval_node_final_rec (node%arg3) if (associated (node%arg4)) call eval_node_final_rec (node%arg4) end select select case (node%type) case (EN_UNARY, EN_BINARY, EN_CONDITIONAL, EN_CONSTANT, EN_BLOCK, & EN_PRT_FUN_UNARY, EN_PRT_FUN_BINARY, & EN_EVAL_FUN_UNARY, EN_EVAL_FUN_BINARY, & EN_LOG_FUN_UNARY, EN_LOG_FUN_BINARY, & EN_INT_FUN_UNARY, EN_INT_FUN_BINARY, & EN_REAL_FUN_UNARY, EN_REAL_FUN_BINARY, & EN_FORMAT_STR, EN_RECORD_CMD) select case (node%result_type) case (V_LOG); deallocate (node%lval) case (V_INT); deallocate (node%ival) case (V_REAL); deallocate (node%rval) case (V_CMPLX); deallocate (node%cval) case (V_SEV); deallocate (node%pval) case (V_PDG); deallocate (node%aval) case (V_STR); deallocate (node%sval) end select deallocate (node%value_is_known) end select end subroutine eval_node_final_rec @ %def eval_node_final_rec @ \subsubsection{Leaf nodes} Initialize a leaf node with a literal constant. <>= subroutine eval_node_init_log (node, lval) type(eval_node_t), intent(out) :: node logical, intent(in) :: lval node%type = EN_CONSTANT node%result_type = V_LOG allocate (node%lval, node%value_is_known) node%lval = lval node%value_is_known = .true. end subroutine eval_node_init_log subroutine eval_node_init_int (node, ival) type(eval_node_t), intent(out) :: node integer, intent(in) :: ival node%type = EN_CONSTANT node%result_type = V_INT allocate (node%ival, node%value_is_known) node%ival = ival node%value_is_known = .true. end subroutine eval_node_init_int subroutine eval_node_init_real (node, rval) type(eval_node_t), intent(out) :: node real(default), intent(in) :: rval node%type = EN_CONSTANT node%result_type = V_REAL allocate (node%rval, node%value_is_known) node%rval = rval node%value_is_known = .true. end subroutine eval_node_init_real subroutine eval_node_init_cmplx (node, cval) type(eval_node_t), intent(out) :: node complex(default), intent(in) :: cval node%type = EN_CONSTANT node%result_type = V_CMPLX allocate (node%cval, node%value_is_known) node%cval = cval node%value_is_known = .true. end subroutine eval_node_init_cmplx subroutine eval_node_init_subevt (node, pval) type(eval_node_t), intent(out) :: node type(subevt_t), intent(in) :: pval node%type = EN_CONSTANT node%result_type = V_SEV allocate (node%pval, node%value_is_known) node%pval = pval node%value_is_known = .true. end subroutine eval_node_init_subevt subroutine eval_node_init_pdg_array (node, aval) type(eval_node_t), intent(out) :: node type(pdg_array_t), intent(in) :: aval node%type = EN_CONSTANT node%result_type = V_PDG allocate (node%aval, node%value_is_known) node%aval = aval node%value_is_known = .true. end subroutine eval_node_init_pdg_array subroutine eval_node_init_string (node, sval) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: sval node%type = EN_CONSTANT node%result_type = V_STR allocate (node%sval, node%value_is_known) node%sval = sval node%value_is_known = .true. end subroutine eval_node_init_string @ %def eval_node_init_log eval_node_init_int eval_node_init_real @ %def eval_node_init_cmplx eval_node_init_prt eval_node_init_subevt @ %def eval_node_init_pdg_array eval_node_init_string @ Initialize a leaf node with a pointer to a named parameter <>= subroutine eval_node_init_log_ptr (node, name, lval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name logical, intent(in), target :: lval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_LOG node%lval => lval node%value_is_known => is_known end subroutine eval_node_init_log_ptr subroutine eval_node_init_int_ptr (node, name, ival, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name integer, intent(in), target :: ival logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_INT node%ival => ival node%value_is_known => is_known end subroutine eval_node_init_int_ptr subroutine eval_node_init_real_ptr (node, name, rval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name real(default), intent(in), target :: rval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_REAL node%rval => rval node%value_is_known => is_known end subroutine eval_node_init_real_ptr subroutine eval_node_init_cmplx_ptr (node, name, cval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name complex(default), intent(in), target :: cval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_CMPLX node%cval => cval node%value_is_known => is_known end subroutine eval_node_init_cmplx_ptr subroutine eval_node_init_subevt_ptr (node, name, pval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(subevt_t), intent(in), target :: pval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_SEV node%pval => pval node%value_is_known => is_known end subroutine eval_node_init_subevt_ptr subroutine eval_node_init_pdg_array_ptr (node, name, aval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(pdg_array_t), intent(in), target :: aval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_PDG node%aval => aval node%value_is_known => is_known end subroutine eval_node_init_pdg_array_ptr subroutine eval_node_init_string_ptr (node, name, sval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(string_t), intent(in), target :: sval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_STR node%sval => sval node%value_is_known => is_known end subroutine eval_node_init_string_ptr @ %def eval_node_init_log_ptr eval_node_init_int_ptr @ %def eval_node_init_real_ptr eval_node_init_cmplx_ptr @ %def eval_node_init_subevt_ptr eval_node_init_string_ptr @ The procedure-pointer cases: <>= subroutine eval_node_init_obs1_int_ptr (node, name, obs1_iptr, p1) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_unary_int), intent(in), pointer :: obs1_iptr type(prt_t), intent(in), target :: p1 node%type = EN_OBS1_INT node%tag = name node%result_type = V_INT node%obs1_int => obs1_iptr node%prt1 => p1 allocate (node%ival, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obs1_int_ptr subroutine eval_node_init_obs2_int_ptr (node, name, obs2_iptr, p1, p2) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_binary_int), intent(in), pointer :: obs2_iptr type(prt_t), intent(in), target :: p1, p2 node%type = EN_OBS2_INT node%tag = name node%result_type = V_INT node%obs2_int => obs2_iptr node%prt1 => p1 node%prt2 => p2 allocate (node%ival, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obs2_int_ptr subroutine eval_node_init_obs1_real_ptr (node, name, obs1_rptr, p1) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_unary_real), intent(in), pointer :: obs1_rptr type(prt_t), intent(in), target :: p1 node%type = EN_OBS1_REAL node%tag = name node%result_type = V_REAL node%obs1_real => obs1_rptr node%prt1 => p1 allocate (node%rval, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obs1_real_ptr subroutine eval_node_init_obs2_real_ptr (node, name, obs2_rptr, p1, p2) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_binary_real), intent(in), pointer :: obs2_rptr type(prt_t), intent(in), target :: p1, p2 node%type = EN_OBS2_REAL node%tag = name node%result_type = V_REAL node%obs2_real => obs2_rptr node%prt1 => p1 node%prt2 => p2 allocate (node%rval, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obs2_real_ptr @ %def eval_node_init_obs1_int_ptr @ %def eval_node_init_obs2_int_ptr @ %def eval_node_init_obs1_real_ptr @ %def eval_node_init_obs2_real_ptr @ \subsubsection{Branch nodes} Initialize a branch node, sub-nodes are given. <>= subroutine eval_node_init_branch (node, tag, result_type, arg1, arg2) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: tag integer, intent(in) :: result_type type(eval_node_t), intent(in), target :: arg1 type(eval_node_t), intent(in), target, optional :: arg2 if (present (arg2)) then node%type = EN_BINARY else node%type = EN_UNARY end if node%tag = tag node%result_type = result_type call eval_node_allocate_value (node) node%arg1 => arg1 if (present (arg2)) node%arg2 => arg2 end subroutine eval_node_init_branch @ %def eval_node_init_branch @ Allocate the node value according to the result type. <>= subroutine eval_node_allocate_value (node) type(eval_node_t), intent(inout) :: node select case (node%result_type) case (V_LOG); allocate (node%lval) case (V_INT); allocate (node%ival) case (V_REAL); allocate (node%rval) case (V_CMPLX); allocate (node%cval) case (V_PDG); allocate (node%aval) case (V_SEV); allocate (node%pval) call subevt_init (node%pval) case (V_STR); allocate (node%sval) end select allocate (node%value_is_known) node%value_is_known = .false. end subroutine eval_node_allocate_value @ %def eval_node_allocate_value @ Initialize a block node which contains, in addition to the expression to be evaluated, a variable definition. The result type is not yet assigned, because we can compile the enclosed expression only after the var list is set up. Note that the node always allocates a new variable list and appends it to the current one. Thus, if the variable redefines an existing one, it only shadows it but does not reset it. Any side-effects are therefore absent and need not be undone outside the block. If the flag [[new]] is set, a variable is (re)declared. This must not be done for intrinsic variables. Vice versa, if the variable is not existent, the [[new]] flag is required. <>= subroutine eval_node_init_block (node, name, type, var_def, var_list) type(eval_node_t), intent(out), target :: node type(string_t), intent(in) :: name integer, intent(in) :: type type(eval_node_t), intent(in), target :: var_def type(var_list_t), intent(in), target :: var_list node%type = EN_BLOCK node%tag = "var_def" node%var_name = name node%arg1 => var_def allocate (node%var_list) call node%var_list%link (var_list) if (var_def%type == EN_CONSTANT) then select case (type) case (V_LOG) call var_list_append_log (node%var_list, name, var_def%lval) case (V_INT) call var_list_append_int (node%var_list, name, var_def%ival) case (V_REAL) call var_list_append_real (node%var_list, name, var_def%rval) case (V_CMPLX) call var_list_append_cmplx (node%var_list, name, var_def%cval) case (V_PDG) call var_list_append_pdg_array & (node%var_list, name, var_def%aval) case (V_SEV) call var_list_append_subevt & (node%var_list, name, var_def%pval) case (V_STR) call var_list_append_string (node%var_list, name, var_def%sval) end select else select case (type) case (V_LOG); call var_list_append_log_ptr & (node%var_list, name, var_def%lval, var_def%value_is_known) case (V_INT); call var_list_append_int_ptr & (node%var_list, name, var_def%ival, var_def%value_is_known) case (V_REAL); call var_list_append_real_ptr & (node%var_list, name, var_def%rval, var_def%value_is_known) case (V_CMPLX); call var_list_append_cmplx_ptr & (node%var_list, name, var_def%cval, var_def%value_is_known) case (V_PDG); call var_list_append_pdg_array_ptr & (node%var_list, name, var_def%aval, var_def%value_is_known) case (V_SEV); call var_list_append_subevt_ptr & (node%var_list, name, var_def%pval, var_def%value_is_known) case (V_STR); call var_list_append_string_ptr & (node%var_list, name, var_def%sval, var_def%value_is_known) end select end if end subroutine eval_node_init_block @ %def eval_node_init_block @ Complete block initialization by assigning the expression to evaluate to [[arg0]]. <>= subroutine eval_node_set_expr (node, arg, result_type) type(eval_node_t), intent(inout) :: node type(eval_node_t), intent(in), target :: arg integer, intent(in), optional :: result_type if (present (result_type)) then node%result_type = result_type else node%result_type = arg%result_type end if call eval_node_allocate_value (node) node%arg0 => arg end subroutine eval_node_set_expr @ %def eval_node_set_block_expr @ Initialize a conditional. There are three branches: the condition (evaluates to logical) and the two alternatives (evaluate both to the same arbitrary type). <>= subroutine eval_node_init_conditional (node, result_type, cond, arg1, arg2) type(eval_node_t), intent(out) :: node integer, intent(in) :: result_type type(eval_node_t), intent(in), target :: cond, arg1, arg2 node%type = EN_CONDITIONAL node%tag = "cond" node%result_type = result_type call eval_node_allocate_value (node) node%arg0 => cond node%arg1 => arg1 node%arg2 => arg2 end subroutine eval_node_init_conditional @ %def eval_node_init_conditional @ Initialize a recording command (which evaluates to a logical constant). The first branch is the ID of the analysis object to be filled, the optional branches 1 to 4 are the values to be recorded. If the event-weight pointer is null, we record values with unit weight. Otherwise, we use the value pointed to as event weight. There can be up to four arguments which represent $x$, $y$, $\Delta y$, $\Delta x$. Therefore, this is the only node type that may fill four sub-nodes. <>= subroutine eval_node_init_record_cmd & (node, event_weight, id, arg1, arg2, arg3, arg4) type(eval_node_t), intent(out) :: node real(default), pointer :: event_weight type(eval_node_t), intent(in), target :: id type(eval_node_t), intent(in), optional, target :: arg1, arg2, arg3, arg4 call eval_node_init_log (node, .true.) node%type = EN_RECORD_CMD node%rval => event_weight node%tag = "record_cmd" node%arg0 => id if (present (arg1)) then node%arg1 => arg1 if (present (arg2)) then node%arg2 => arg2 if (present (arg3)) then node%arg3 => arg3 if (present (arg4)) then node%arg4 => arg4 end if end if end if end if end subroutine eval_node_init_record_cmd @ %def eval_node_init_record_cmd @ Initialize a node for operations on subevents. The particle lists (one or two) are inserted as [[arg1]] and [[arg2]]. We allocated particle pointers as temporaries for iterating over particle lists. The procedure pointer which holds the function to evaluate for the subevents (e.g., combine, select) is also initialized. <>= subroutine eval_node_init_prt_fun_unary (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(unary_sev) :: proc node%type = EN_PRT_FUN_UNARY node%tag = name node%result_type = V_SEV call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%op1_sev => proc end subroutine eval_node_init_prt_fun_unary subroutine eval_node_init_prt_fun_binary (node, arg1, arg2, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name procedure(binary_sev) :: proc node%type = EN_PRT_FUN_BINARY node%tag = name node%result_type = V_SEV call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) node%op2_sev => proc end subroutine eval_node_init_prt_fun_binary @ %def eval_node_init_prt_fun_unary eval_node_init_prt_fun_binary @ Similar, but for particle-list functions that evaluate to a real value. <>= subroutine eval_node_init_eval_fun_unary (node, arg1, name) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name node%type = EN_EVAL_FUN_UNARY node%tag = name node%result_type = V_REAL call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) end subroutine eval_node_init_eval_fun_unary subroutine eval_node_init_eval_fun_binary (node, arg1, arg2, name) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name node%type = EN_EVAL_FUN_BINARY node%tag = name node%result_type = V_REAL call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) end subroutine eval_node_init_eval_fun_binary @ %def eval_node_init_eval_fun_unary eval_node_init_eval_fun_binary @ These are for particle-list functions that evaluate to a logical value. <>= subroutine eval_node_init_log_fun_unary (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(unary_cut) :: proc node%type = EN_LOG_FUN_UNARY node%tag = name node%result_type = V_LOG call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%op1_cut => proc end subroutine eval_node_init_log_fun_unary subroutine eval_node_init_log_fun_binary (node, arg1, arg2, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name procedure(binary_cut) :: proc node%type = EN_LOG_FUN_BINARY node%tag = name node%result_type = V_LOG call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) node%op2_cut => proc end subroutine eval_node_init_log_fun_binary @ %def eval_node_init_log_fun_unary eval_node_init_log_fun_binary @ These are for particle-list functions that evaluate to an integer value. <>= subroutine eval_node_init_int_fun_unary (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(unary_evi) :: proc node%type = EN_INT_FUN_UNARY node%tag = name node%result_type = V_INT call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%op1_evi => proc end subroutine eval_node_init_int_fun_unary subroutine eval_node_init_int_fun_binary (node, arg1, arg2, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name procedure(binary_evi) :: proc node%type = EN_INT_FUN_BINARY node%tag = name node%result_type = V_INT call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) node%op2_evi => proc end subroutine eval_node_init_int_fun_binary @ %def eval_node_init_int_fun_unary eval_node_init_int_fun_binary @ These are for particle-list functions that evaluate to a real value. <>= subroutine eval_node_init_real_fun_unary (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(unary_evr) :: proc node%type = EN_REAL_FUN_UNARY node%tag = name node%result_type = V_INT call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%op1_evr => proc end subroutine eval_node_init_real_fun_unary subroutine eval_node_init_real_fun_binary (node, arg1, arg2, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name procedure(binary_evr) :: proc node%type = EN_REAL_FUN_BINARY node%tag = name node%result_type = V_INT call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) node%op2_evr => proc end subroutine eval_node_init_real_fun_binary @ %def eval_node_init_real_fun_unary eval_node_init_real_fun_binary @ Initialize a node for a string formatting function (sprintf). <>= subroutine eval_node_init_format_string (node, fmt, arg, name, n_args) type(eval_node_t), intent(out) :: node type(eval_node_t), pointer :: fmt, arg type(string_t), intent(in) :: name integer, intent(in) :: n_args node%type = EN_FORMAT_STR node%tag = name node%result_type = V_STR call eval_node_allocate_value (node) node%arg0 => fmt node%arg1 => arg allocate (node%ival) node%ival = n_args end subroutine eval_node_init_format_string @ %def eval_node_init_format_string @ If particle functions depend upon a condition (or an expression is evaluated), the observables that can be evaluated for the given particles have to be thrown on the local variable stack. This is done here. Each observable is initialized with the particle pointers which have been allocated for the node. The integer variable that is referred to by the [[Index]] pseudo-observable is always known when it is referred to. <>= subroutine eval_node_set_observables (node, var_list) type(eval_node_t), intent(inout) :: node type(var_list_t), intent(in), target :: var_list logical, save, target :: known = .true. allocate (node%var_list) call node%var_list%link (var_list) allocate (node%index, source = 0) call var_list_append_int_ptr & (node%var_list, var_str ("Index"), node%index, known, intrinsic=.true.) if (.not. associated (node%prt2)) then call var_list_set_observables_unary & (node%var_list, node%prt1) else call var_list_set_observables_binary & (node%var_list, node%prt1, node%prt2) end if end subroutine eval_node_set_observables @ %def eval_node_set_observables @ \subsubsection{Output} <>= procedure :: write => eval_node_write <>= subroutine eval_node_write (node, unit, indent) class(eval_node_t), intent(in) :: node integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind u = given_output_unit (unit); if (u < 0) return ind = 0; if (present (indent)) ind = indent write (u, "(A)", advance="no") repeat ("| ", ind) // "o " select case (node%type) case (EN_UNARY, EN_BINARY, EN_CONDITIONAL, & EN_PRT_FUN_UNARY, EN_PRT_FUN_BINARY, & EN_EVAL_FUN_UNARY, EN_EVAL_FUN_BINARY, & EN_LOG_FUN_UNARY, EN_LOG_FUN_BINARY, & EN_INT_FUN_UNARY, EN_INT_FUN_BINARY, & EN_REAL_FUN_UNARY, EN_REAL_FUN_BINARY) write (u, "(A)", advance="no") "[" // char (node%tag) // "] =" case (EN_CONSTANT) write (u, "(A)", advance="no") "[const] =" case (EN_VARIABLE) write (u, "(A)", advance="no") char (node%tag) // " =>" case (EN_OBS1_INT, EN_OBS2_INT, EN_OBS1_REAL, EN_OBS2_REAL) write (u, "(A)", advance="no") char (node%tag) // " =" case (EN_BLOCK) write (u, "(A)", advance="no") "[" // char (node%tag) // "]" // & char (node%var_name) // " [expr] = " case default write (u, "(A)", advance="no") "[???] =" end select select case (node%result_type) case (V_LOG) if (node%value_is_known) then if (node%lval) then write (u, "(1x,A)") "true" else write (u, "(1x,A)") "false" end if else write (u, "(1x,A)") "[unknown logical]" end if case (V_INT) if (node%value_is_known) then write (u, "(1x,I0)") node%ival else write (u, "(1x,A)") "[unknown integer]" end if case (V_REAL) if (node%value_is_known) then write (u, "(1x," // FMT_19 // ")") node%rval else write (u, "(1x,A)") "[unknown real]" end if case (V_CMPLX) if (node%value_is_known) then write (u, "(1x,'('," // FMT_19 // ",','," // & FMT_19 // ",')')") node%cval else write (u, "(1x,A)") "[unknown complex]" end if case (V_SEV) if (char (node%tag) == "@evt") then write (u, "(1x,A)") "[event subevent]" else if (node%value_is_known) then call subevt_write & (node%pval, unit, prefix = repeat ("| ", ind + 1)) else write (u, "(1x,A)") "[unknown subevent]" end if case (V_PDG) write (u, "(1x)", advance="no") call pdg_array_write (node%aval, u); write (u, *) case (V_STR) if (node%value_is_known) then write (u, "(A)") '"' // char (node%sval) // '"' else write (u, "(1x,A)") "[unknown string]" end if case default write (u, "(1x,A)") "[empty]" end select select case (node%type) case (EN_OBS1_INT, EN_OBS1_REAL) write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt1 =" call prt_write (node%prt1, unit) case (EN_OBS2_INT, EN_OBS2_REAL) write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt1 =" call prt_write (node%prt1, unit) write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt2 =" call prt_write (node%prt2, unit) end select end subroutine eval_node_write recursive subroutine eval_node_write_rec (node, unit, indent) type(eval_node_t), intent(in) :: node integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind u = given_output_unit (unit); if (u < 0) return ind = 0; if (present (indent)) ind = indent call eval_node_write (node, unit, indent) select case (node%type) case (EN_UNARY) if (associated (node%arg0)) & call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) case (EN_BINARY) if (associated (node%arg0)) & call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) call eval_node_write_rec (node%arg2, unit, ind+1) case (EN_BLOCK) call eval_node_write_rec (node%arg1, unit, ind+1) call eval_node_write_rec (node%arg0, unit, ind+1) case (EN_CONDITIONAL) call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) call eval_node_write_rec (node%arg2, unit, ind+1) case (EN_PRT_FUN_UNARY, EN_EVAL_FUN_UNARY, & EN_LOG_FUN_UNARY, EN_INT_FUN_UNARY, EN_REAL_FUN_UNARY) if (associated (node%arg0)) & call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) case (EN_PRT_FUN_BINARY, EN_EVAL_FUN_BINARY, & EN_LOG_FUN_BINARY, EN_INT_FUN_BINARY, EN_REAL_FUN_BINARY) if (associated (node%arg0)) & call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) call eval_node_write_rec (node%arg2, unit, ind+1) case (EN_RECORD_CMD) if (associated (node%arg1)) then call eval_node_write_rec (node%arg1, unit, ind+1) if (associated (node%arg2)) then call eval_node_write_rec (node%arg2, unit, ind+1) if (associated (node%arg3)) then call eval_node_write_rec (node%arg3, unit, ind+1) if (associated (node%arg4)) then call eval_node_write_rec (node%arg4, unit, ind+1) end if end if end if end if end select end subroutine eval_node_write_rec @ %def eval_node_write eval_node_write_rec @ \subsection{Operation types} For the operations associated to evaluation tree nodes, we define abstract interfaces for all cases. Particles/subevents are transferred by-reference, to avoid unnecessary copying. Therefore, subroutines instead of functions. <>= abstract interface logical function unary_log (arg) import eval_node_t type(eval_node_t), intent(in) :: arg end function unary_log end interface abstract interface integer function unary_int (arg) import eval_node_t type(eval_node_t), intent(in) :: arg end function unary_int end interface abstract interface real(default) function unary_real (arg) import default import eval_node_t type(eval_node_t), intent(in) :: arg end function unary_real end interface abstract interface complex(default) function unary_cmplx (arg) import default import eval_node_t type(eval_node_t), intent(in) :: arg end function unary_cmplx end interface abstract interface subroutine unary_pdg (pdg_array, arg) import pdg_array_t import eval_node_t type(pdg_array_t), intent(out) :: pdg_array type(eval_node_t), intent(in) :: arg end subroutine unary_pdg end interface abstract interface subroutine unary_sev (subevt, arg, arg0) import subevt_t import eval_node_t type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: arg type(eval_node_t), intent(inout), optional :: arg0 end subroutine unary_sev end interface abstract interface subroutine unary_str (string, arg) import string_t import eval_node_t type(string_t), intent(out) :: string type(eval_node_t), intent(in) :: arg end subroutine unary_str end interface abstract interface logical function unary_cut (arg1, arg0) import eval_node_t type(eval_node_t), intent(in) :: arg1 type(eval_node_t), intent(inout) :: arg0 end function unary_cut end interface abstract interface subroutine unary_evi (ival, arg1, arg0) import eval_node_t integer, intent(out) :: ival type(eval_node_t), intent(in) :: arg1 type(eval_node_t), intent(inout), optional :: arg0 end subroutine unary_evi end interface abstract interface subroutine unary_evr (rval, arg1, arg0) import eval_node_t, default real(default), intent(out) :: rval type(eval_node_t), intent(in) :: arg1 type(eval_node_t), intent(inout), optional :: arg0 end subroutine unary_evr end interface abstract interface logical function binary_log (arg1, arg2) import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 end function binary_log end interface abstract interface integer function binary_int (arg1, arg2) import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 end function binary_int end interface abstract interface real(default) function binary_real (arg1, arg2) import default import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 end function binary_real end interface abstract interface complex(default) function binary_cmplx (arg1, arg2) import default import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 end function binary_cmplx end interface abstract interface subroutine binary_pdg (pdg_array, arg1, arg2) import pdg_array_t import eval_node_t type(pdg_array_t), intent(out) :: pdg_array type(eval_node_t), intent(in) :: arg1, arg2 end subroutine binary_pdg end interface abstract interface subroutine binary_sev (subevt, arg1, arg2, arg0) import subevt_t import eval_node_t type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: arg1, arg2 type(eval_node_t), intent(inout), optional :: arg0 end subroutine binary_sev end interface abstract interface subroutine binary_str (string, arg1, arg2) import string_t import eval_node_t type(string_t), intent(out) :: string type(eval_node_t), intent(in) :: arg1, arg2 end subroutine binary_str end interface abstract interface logical function binary_cut (arg1, arg2, arg0) import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 type(eval_node_t), intent(inout) :: arg0 end function binary_cut end interface abstract interface subroutine binary_evi (ival, arg1, arg2, arg0) import eval_node_t integer, intent(out) :: ival type(eval_node_t), intent(in) :: arg1, arg2 type(eval_node_t), intent(inout), optional :: arg0 end subroutine binary_evi end interface abstract interface subroutine binary_evr (rval, arg1, arg2, arg0) import eval_node_t, default real(default), intent(out) :: rval type(eval_node_t), intent(in) :: arg1, arg2 type(eval_node_t), intent(inout), optional :: arg0 end subroutine binary_evr end interface @ The following subroutines set the procedure pointer: <>= subroutine eval_node_set_op1_log (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_log) :: op en%op1_log => op end subroutine eval_node_set_op1_log subroutine eval_node_set_op1_int (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_int) :: op en%op1_int => op end subroutine eval_node_set_op1_int subroutine eval_node_set_op1_real (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_real) :: op en%op1_real => op end subroutine eval_node_set_op1_real subroutine eval_node_set_op1_cmplx (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_cmplx) :: op en%op1_cmplx => op end subroutine eval_node_set_op1_cmplx subroutine eval_node_set_op1_pdg (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_pdg) :: op en%op1_pdg => op end subroutine eval_node_set_op1_pdg subroutine eval_node_set_op1_sev (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_sev) :: op en%op1_sev => op end subroutine eval_node_set_op1_sev subroutine eval_node_set_op1_str (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_str) :: op en%op1_str => op end subroutine eval_node_set_op1_str subroutine eval_node_set_op2_log (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_log) :: op en%op2_log => op end subroutine eval_node_set_op2_log subroutine eval_node_set_op2_int (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_int) :: op en%op2_int => op end subroutine eval_node_set_op2_int subroutine eval_node_set_op2_real (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_real) :: op en%op2_real => op end subroutine eval_node_set_op2_real subroutine eval_node_set_op2_cmplx (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_cmplx) :: op en%op2_cmplx => op end subroutine eval_node_set_op2_cmplx subroutine eval_node_set_op2_pdg (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_pdg) :: op en%op2_pdg => op end subroutine eval_node_set_op2_pdg subroutine eval_node_set_op2_sev (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_sev) :: op en%op2_sev => op end subroutine eval_node_set_op2_sev subroutine eval_node_set_op2_str (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_str) :: op en%op2_str => op end subroutine eval_node_set_op2_str @ %def eval_node_set_operator @ \subsection{Specific operators} Our expression syntax contains all Fortran functions that make sense. These functions have to be provided in a form that they can be used in procedures pointers, and have the abstract interfaces above. For some intrinsic functions, we could use specific versions provided by Fortran directly. However, this has two drawbacks: (i) We should work with the values instead of the eval-nodes as argument, which complicates the interface; (ii) more importantly, the [[default]] real type need not be equivalent to double precision. This would, at least, introduce system dependencies. Finally, for operators there are no specific versions. Therefore, we write wrappers for all possible functions, at the expense of some overhead. \subsubsection{Binary numerical functions} <>= integer function add_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival + en2%ival end function add_ii real(default) function add_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival + en2%rval end function add_ir complex(default) function add_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival + en2%cval end function add_ic real(default) function add_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval + en2%ival end function add_ri complex(default) function add_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval + en2%ival end function add_ci complex(default) function add_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval + en2%rval end function add_cr complex(default) function add_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval + en2%cval end function add_rc real(default) function add_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval + en2%rval end function add_rr complex(default) function add_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval + en2%cval end function add_cc integer function sub_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival - en2%ival end function sub_ii real(default) function sub_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival - en2%rval end function sub_ir real(default) function sub_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval - en2%ival end function sub_ri complex(default) function sub_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival - en2%cval end function sub_ic complex(default) function sub_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval - en2%ival end function sub_ci complex(default) function sub_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval - en2%rval end function sub_cr complex(default) function sub_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval - en2%cval end function sub_rc real(default) function sub_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval - en2%rval end function sub_rr complex(default) function sub_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval - en2%cval end function sub_cc integer function mul_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival * en2%ival end function mul_ii real(default) function mul_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival * en2%rval end function mul_ir real(default) function mul_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval * en2%ival end function mul_ri complex(default) function mul_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival * en2%cval end function mul_ic complex(default) function mul_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval * en2%ival end function mul_ci complex(default) function mul_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval * en2%cval end function mul_rc complex(default) function mul_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval * en2%rval end function mul_cr real(default) function mul_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval * en2%rval end function mul_rr complex(default) function mul_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval * en2%cval end function mul_cc integer function div_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (en2%ival == 0) then if (en1%ival >= 0) then call msg_warning ("division by zero: " // int2char (en1%ival) // & " / 0 ; result set to 0") else call msg_warning ("division by zero: (" // int2char (en1%ival) // & ") / 0 ; result set to 0") end if y = 0 return end if y = en1%ival / en2%ival end function div_ii real(default) function div_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival / en2%rval end function div_ir real(default) function div_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval / en2%ival end function div_ri complex(default) function div_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival / en2%cval end function div_ic complex(default) function div_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval / en2%ival end function div_ci complex(default) function div_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval / en2%cval end function div_rc complex(default) function div_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval / en2%rval end function div_cr real(default) function div_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval / en2%rval end function div_rr complex(default) function div_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval / en2%cval end function div_cc integer function pow_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 integer :: a, b real(default) :: rres a = en1%ival b = en2%ival if ((a == 0) .and. (b < 0)) then call msg_warning ("division by zero: " // int2char (a) // & " ^ (" // int2char (b) // ") ; result set to 0") y = 0 return end if rres = real(a, default) ** b y = rres if (real(y, default) /= rres) then if (b < 0) then call msg_warning ("result of all-integer operation " // & int2char (a) // " ^ (" // int2char (b) // & ") has been trucated to "// int2char (y), & [ var_str ("Chances are that you want to use " // & "reals instead of integers at this point.") ]) else call msg_warning ("integer overflow in " // int2char (a) // & " ^ " // int2char (b) // " ; result is " // int2char (y), & [ var_str ("Using reals instead of integers might help.")]) end if end if end function pow_ii real(default) function pow_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval ** en2%ival end function pow_ri complex(default) function pow_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval ** en2%ival end function pow_ci real(default) function pow_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival ** en2%rval end function pow_ir real(default) function pow_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval ** en2%rval end function pow_rr complex(default) function pow_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval ** en2%rval end function pow_cr complex(default) function pow_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival ** en2%cval end function pow_ic complex(default) function pow_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval ** en2%cval end function pow_rc complex(default) function pow_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval ** en2%cval end function pow_cc integer function max_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = max (en1%ival, en2%ival) end function max_ii real(default) function max_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = max (real (en1%ival, default), en2%rval) end function max_ir real(default) function max_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = max (en1%rval, real (en2%ival, default)) end function max_ri real(default) function max_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = max (en1%rval, en2%rval) end function max_rr integer function min_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = min (en1%ival, en2%ival) end function min_ii real(default) function min_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = min (real (en1%ival, default), en2%rval) end function min_ir real(default) function min_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = min (en1%rval, real (en2%ival, default)) end function min_ri real(default) function min_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = min (en1%rval, en2%rval) end function min_rr integer function mod_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = mod (en1%ival, en2%ival) end function mod_ii real(default) function mod_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = mod (real (en1%ival, default), en2%rval) end function mod_ir real(default) function mod_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = mod (en1%rval, real (en2%ival, default)) end function mod_ri real(default) function mod_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = mod (en1%rval, en2%rval) end function mod_rr integer function modulo_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = modulo (en1%ival, en2%ival) end function modulo_ii real(default) function modulo_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = modulo (real (en1%ival, default), en2%rval) end function modulo_ir real(default) function modulo_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = modulo (en1%rval, real (en2%ival, default)) end function modulo_ri real(default) function modulo_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = modulo (en1%rval, en2%rval) end function modulo_rr @ \subsubsection{Unary numeric functions} <>= real(default) function real_i (en) result (y) type(eval_node_t), intent(in) :: en y = en%ival end function real_i real(default) function real_c (en) result (y) type(eval_node_t), intent(in) :: en y = en%cval end function real_c integer function int_r (en) result (y) type(eval_node_t), intent(in) :: en y = en%rval end function int_r complex(default) function cmplx_i (en) result (y) type(eval_node_t), intent(in) :: en y = en%ival end function cmplx_i integer function int_c (en) result (y) type(eval_node_t), intent(in) :: en y = en%cval end function int_c complex(default) function cmplx_r (en) result (y) type(eval_node_t), intent(in) :: en y = en%rval end function cmplx_r integer function nint_r (en) result (y) type(eval_node_t), intent(in) :: en y = nint (en%rval) end function nint_r integer function floor_r (en) result (y) type(eval_node_t), intent(in) :: en y = floor (en%rval) end function floor_r integer function ceiling_r (en) result (y) type(eval_node_t), intent(in) :: en y = ceiling (en%rval) end function ceiling_r integer function neg_i (en) result (y) type(eval_node_t), intent(in) :: en y = - en%ival end function neg_i real(default) function neg_r (en) result (y) type(eval_node_t), intent(in) :: en y = - en%rval end function neg_r complex(default) function neg_c (en) result (y) type(eval_node_t), intent(in) :: en y = - en%cval end function neg_c integer function abs_i (en) result (y) type(eval_node_t), intent(in) :: en y = abs (en%ival) end function abs_i real(default) function abs_r (en) result (y) type(eval_node_t), intent(in) :: en y = abs (en%rval) end function abs_r real(default) function abs_c (en) result (y) type(eval_node_t), intent(in) :: en y = abs (en%cval) end function abs_c integer function conjg_i (en) result (y) type(eval_node_t), intent(in) :: en y = en%ival end function conjg_i real(default) function conjg_r (en) result (y) type(eval_node_t), intent(in) :: en y = en%rval end function conjg_r complex(default) function conjg_c (en) result (y) type(eval_node_t), intent(in) :: en y = conjg (en%cval) end function conjg_c integer function sgn_i (en) result (y) type(eval_node_t), intent(in) :: en y = sign (1, en%ival) end function sgn_i real(default) function sgn_r (en) result (y) type(eval_node_t), intent(in) :: en y = sign (1._default, en%rval) end function sgn_r real(default) function sqrt_r (en) result (y) type(eval_node_t), intent(in) :: en y = sqrt (en%rval) end function sqrt_r real(default) function exp_r (en) result (y) type(eval_node_t), intent(in) :: en y = exp (en%rval) end function exp_r real(default) function log_r (en) result (y) type(eval_node_t), intent(in) :: en y = log (en%rval) end function log_r real(default) function log10_r (en) result (y) type(eval_node_t), intent(in) :: en y = log10 (en%rval) end function log10_r complex(default) function sqrt_c (en) result (y) type(eval_node_t), intent(in) :: en y = sqrt (en%cval) end function sqrt_c complex(default) function exp_c (en) result (y) type(eval_node_t), intent(in) :: en y = exp (en%cval) end function exp_c complex(default) function log_c (en) result (y) type(eval_node_t), intent(in) :: en y = log (en%cval) end function log_c real(default) function sin_r (en) result (y) type(eval_node_t), intent(in) :: en y = sin (en%rval) end function sin_r real(default) function cos_r (en) result (y) type(eval_node_t), intent(in) :: en y = cos (en%rval) end function cos_r real(default) function tan_r (en) result (y) type(eval_node_t), intent(in) :: en y = tan (en%rval) end function tan_r real(default) function asin_r (en) result (y) type(eval_node_t), intent(in) :: en y = asin (en%rval) end function asin_r real(default) function acos_r (en) result (y) type(eval_node_t), intent(in) :: en y = acos (en%rval) end function acos_r real(default) function atan_r (en) result (y) type(eval_node_t), intent(in) :: en y = atan (en%rval) end function atan_r complex(default) function sin_c (en) result (y) type(eval_node_t), intent(in) :: en y = sin (en%cval) end function sin_c complex(default) function cos_c (en) result (y) type(eval_node_t), intent(in) :: en y = cos (en%cval) end function cos_c real(default) function sinh_r (en) result (y) type(eval_node_t), intent(in) :: en y = sinh (en%rval) end function sinh_r real(default) function cosh_r (en) result (y) type(eval_node_t), intent(in) :: en y = cosh (en%rval) end function cosh_r real(default) function tanh_r (en) result (y) type(eval_node_t), intent(in) :: en y = tanh (en%rval) end function tanh_r real(default) function asinh_r (en) result (y) type(eval_node_t), intent(in) :: en y = asinh (en%rval) end function asinh_r real(default) function acosh_r (en) result (y) type(eval_node_t), intent(in) :: en y = acosh (en%rval) end function acosh_r real(default) function atanh_r (en) result (y) type(eval_node_t), intent(in) :: en y = atanh (en%rval) end function atanh_r @ \subsubsection{Binary logical functions} Logical expressions: <>= logical function ignore_first_ll (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en2%lval end function ignore_first_ll logical function or_ll (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%lval .or. en2%lval end function or_ll logical function and_ll (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%lval .and. en2%lval end function and_ll @ Comparisons: <>= logical function comp_lt_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival < en2%ival end function comp_lt_ii logical function comp_lt_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival < en2%rval end function comp_lt_ir logical function comp_lt_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval < en2%ival end function comp_lt_ri logical function comp_lt_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval < en2%rval end function comp_lt_rr logical function comp_gt_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival > en2%ival end function comp_gt_ii logical function comp_gt_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival > en2%rval end function comp_gt_ir logical function comp_gt_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval > en2%ival end function comp_gt_ri logical function comp_gt_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval > en2%rval end function comp_gt_rr logical function comp_le_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival <= en2%ival end function comp_le_ii logical function comp_le_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival <= en2%rval end function comp_le_ir logical function comp_le_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval <= en2%ival end function comp_le_ri logical function comp_le_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval <= en2%rval end function comp_le_rr logical function comp_ge_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival >= en2%ival end function comp_ge_ii logical function comp_ge_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival >= en2%rval end function comp_ge_ir logical function comp_ge_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval >= en2%ival end function comp_ge_ri logical function comp_ge_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval >= en2%rval end function comp_ge_rr logical function comp_eq_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival == en2%ival end function comp_eq_ii logical function comp_eq_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival == en2%rval end function comp_eq_ir logical function comp_eq_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval == en2%ival end function comp_eq_ri logical function comp_eq_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval == en2%rval end function comp_eq_rr logical function comp_eq_ss (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%sval == en2%sval end function comp_eq_ss logical function comp_ne_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival /= en2%ival end function comp_ne_ii logical function comp_ne_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival /= en2%rval end function comp_ne_ir logical function comp_ne_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval /= en2%ival end function comp_ne_ri logical function comp_ne_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval /= en2%rval end function comp_ne_rr logical function comp_ne_ss (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%sval /= en2%sval end function comp_ne_ss @ Comparisons with tolerance: <>= logical function comp_se_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%ival - en2%ival) <= en1%tolerance else y = en1%ival == en2%ival end if end function comp_se_ii logical function comp_se_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%rval - en2%ival) <= en1%tolerance else y = en1%rval == en2%ival end if end function comp_se_ri logical function comp_se_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%ival - en2%rval) <= en1%tolerance else y = en1%ival == en2%rval end if end function comp_se_ir logical function comp_se_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%rval - en2%rval) <= en1%tolerance else y = en1%rval == en2%rval end if end function comp_se_rr logical function comp_ns_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%ival - en2%ival) > en1%tolerance else y = en1%ival /= en2%ival end if end function comp_ns_ii logical function comp_ns_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%rval - en2%ival) > en1%tolerance else y = en1%rval /= en2%ival end if end function comp_ns_ri logical function comp_ns_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%ival - en2%rval) > en1%tolerance else y = en1%ival /= en2%rval end if end function comp_ns_ir logical function comp_ns_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%rval - en2%rval) > en1%tolerance else y = en1%rval /= en2%rval end if end function comp_ns_rr logical function comp_ls_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival <= en2%ival + en1%tolerance else y = en1%ival <= en2%ival end if end function comp_ls_ii logical function comp_ls_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval <= en2%ival + en1%tolerance else y = en1%rval <= en2%ival end if end function comp_ls_ri logical function comp_ls_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival <= en2%rval + en1%tolerance else y = en1%ival <= en2%rval end if end function comp_ls_ir logical function comp_ls_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval <= en2%rval + en1%tolerance else y = en1%rval <= en2%rval end if end function comp_ls_rr logical function comp_ll_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival < en2%ival - en1%tolerance else y = en1%ival < en2%ival end if end function comp_ll_ii logical function comp_ll_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval < en2%ival - en1%tolerance else y = en1%rval < en2%ival end if end function comp_ll_ri logical function comp_ll_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival < en2%rval - en1%tolerance else y = en1%ival < en2%rval end if end function comp_ll_ir logical function comp_ll_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval < en2%rval - en1%tolerance else y = en1%rval < en2%rval end if end function comp_ll_rr logical function comp_gs_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival >= en2%ival - en1%tolerance else y = en1%ival >= en2%ival end if end function comp_gs_ii logical function comp_gs_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval >= en2%ival - en1%tolerance else y = en1%rval >= en2%ival end if end function comp_gs_ri logical function comp_gs_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival >= en2%rval - en1%tolerance else y = en1%ival >= en2%rval end if end function comp_gs_ir logical function comp_gs_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval >= en2%rval - en1%tolerance else y = en1%rval >= en2%rval end if end function comp_gs_rr logical function comp_gg_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival > en2%ival + en1%tolerance else y = en1%ival > en2%ival end if end function comp_gg_ii logical function comp_gg_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval > en2%ival + en1%tolerance else y = en1%rval > en2%ival end if end function comp_gg_ri logical function comp_gg_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival > en2%rval + en1%tolerance else y = en1%ival > en2%rval end if end function comp_gg_ir logical function comp_gg_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval > en2%rval + en1%tolerance else y = en1%rval > en2%rval end if end function comp_gg_rr @ \subsubsection{Unary logical functions} <>= logical function not_l (en) result (y) type(eval_node_t), intent(in) :: en y = .not. en%lval end function not_l @ \subsubsection{Unary PDG-array functions} Make a PDG-array object from an integer. <>= subroutine pdg_i (pdg_array, en) type(pdg_array_t), intent(out) :: pdg_array type(eval_node_t), intent(in) :: en pdg_array = en%ival end subroutine pdg_i @ \subsubsection{Binary PDG-array functions} Concatenate two PDG-array objects. <>= subroutine concat_cc (pdg_array, en1, en2) type(pdg_array_t), intent(out) :: pdg_array type(eval_node_t), intent(in) :: en1, en2 pdg_array = en1%aval // en2%aval end subroutine concat_cc @ \subsubsection{Unary particle-list functions} Combine all particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test. <>= subroutine collect_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = subevt_get_length (en1%pval) allocate (mask1 (n)) if (present (en0)) then do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) mask1(i) = en0%lval end do else mask1 = .true. end if call subevt_collect (subevt, en1%pval, mask1) end subroutine collect_p @ %def collect_p @ Cluster the particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test. <>= subroutine cluster_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i !!! Should not be initialized for every event type(jet_definition_t) :: jet_def logical :: keep_jets, exclusive call jet_def%init (en1%jet_algorithm, en1%jet_r, en1%jet_p, en1%jet_ycut) n = subevt_get_length (en1%pval) allocate (mask1 (n)) if (present (en0)) then do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) mask1(i) = en0%lval end do else mask1 = .true. end if if (associated (en1%var_list)) then keep_jets = en1%var_list%get_lval (var_str("?keep_flavors_when_clustering")) else keep_jets = .false. end if exclusive = .false. select case (en1%jet_algorithm) case (ee_kt_algorithm) exclusive = .true. case (ee_genkt_algorithm) if (en1%jet_r > Pi) exclusive = .true. end select call subevt_cluster (subevt, en1%pval, en1%jet_dcut, mask1, & jet_def, keep_jets, exclusive) call jet_def%final () end subroutine cluster_p @ %def cluster_p @ Select all particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test. <>= subroutine select_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = subevt_get_length (en1%pval) allocate (mask1 (n)) if (present (en0)) then do i = 1, subevt_get_length (en1%pval) en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) mask1(i) = en0%lval end do else mask1 = .true. end if call subevt_select (subevt, en1%pval, mask1) end subroutine select_p @ %def select_p [[select_b_jet_p]], [[select_non_b_jet_p]], [[select_c_jet_p]], and [[select_light_jet_p]] are special selection function acting on a subevent of combined particles (jets) and result in a list of $b$ jets, non-$b$ jets (i.e. $c$ and light jets), $c$ jets, and light jets, respectively. <>= subroutine select_b_jet_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = subevt_get_length (en1%pval) allocate (mask1 (n)) do i = 1, subevt_get_length (en1%pval) mask1(i) = prt_is_b_jet (subevt_get_prt (en1%pval, i)) if (present (en0)) then en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) mask1(i) = en0%lval .and. mask1(i) end if end do call subevt_select (subevt, en1%pval, mask1) end subroutine select_b_jet_p @ %def select_b_jet_p <>= subroutine select_non_b_jet_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = subevt_get_length (en1%pval) allocate (mask1 (n)) do i = 1, subevt_get_length (en1%pval) mask1(i) = .not. prt_is_b_jet (subevt_get_prt (en1%pval, i)) if (present (en0)) then en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) mask1(i) = en0%lval .and. mask1(i) end if end do call subevt_select (subevt, en1%pval, mask1) end subroutine select_non_b_jet_p @ %def select_non_b_jet_p <>= subroutine select_c_jet_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = subevt_get_length (en1%pval) allocate (mask1 (n)) do i = 1, subevt_get_length (en1%pval) mask1(i) = .not. prt_is_b_jet (subevt_get_prt (en1%pval, i)) & .and. prt_is_c_jet (subevt_get_prt (en1%pval, i)) if (present (en0)) then en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) mask1(i) = en0%lval .and. mask1(i) end if end do call subevt_select (subevt, en1%pval, mask1) end subroutine select_c_jet_p @ %def select_c_jet_p <>= subroutine select_light_jet_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = subevt_get_length (en1%pval) allocate (mask1 (n)) do i = 1, subevt_get_length (en1%pval) mask1(i) = .not. prt_is_b_jet (subevt_get_prt (en1%pval, i)) & .and. .not. prt_is_c_jet (subevt_get_prt (en1%pval, i)) if (present (en0)) then en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) mask1(i) = en0%lval .and. mask1(i) end if end do call subevt_select (subevt, en1%pval, mask1) end subroutine select_light_jet_p @ %def select_light_jet_p @ Extract the particle with index given by [[en0]] from the argument list. Negative indices count from the end. If [[en0]] is absent, extract the first particle. The result is a list with a single entry, or no entries if the original list was empty or if the index is out of range. This function has no counterpart with two arguments. <>= subroutine extract_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 integer :: index if (present (en0)) then call eval_node_evaluate (en0) select case (en0%result_type) case (V_INT); index = en0%ival case default call eval_node_write (en0) call msg_fatal (" Index parameter of 'extract' must be integer.") end select else index = 1 end if call subevt_extract (subevt, en1%pval, index) end subroutine extract_p @ %def extract_p @ Sort the subevent according to the result of evaluating [[en0]]. If [[en0]] is absent, sort by default method (PDG code, particles before antiparticles). <>= subroutine sort_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 integer, dimension(:), allocatable :: ival real(default), dimension(:), allocatable :: rval integer :: i, n n = subevt_get_length (en1%pval) if (present (en0)) then select case (en0%result_type) case (V_INT); allocate (ival (n)) case (V_REAL); allocate (rval (n)) end select do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) select case (en0%result_type) case (V_INT); ival(i) = en0%ival case (V_REAL); rval(i) = en0%rval end select end do select case (en0%result_type) case (V_INT); call subevt_sort (subevt, en1%pval, ival) case (V_REAL); call subevt_sort (subevt, en1%pval, rval) end select else call subevt_sort (subevt, en1%pval) end if end subroutine sort_p @ %def sort_p @ The following functions return a logical value. [[all]] evaluates to true if the condition [[en0]] is true for all elements of the subevent. [[any]] and [[no]] are analogous. <>= function all_p (en1, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 integer :: i, n n = subevt_get_length (en1%pval) lval = .true. do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) lval = en0%lval if (.not. lval) exit end do end function all_p function any_p (en1, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 integer :: i, n n = subevt_get_length (en1%pval) lval = .false. do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) lval = en0%lval if (lval) exit end do end function any_p function no_p (en1, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 integer :: i, n n = subevt_get_length (en1%pval) lval = .true. do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) lval = .not. en0%lval if (lval) exit end do end function no_p @ %def all_p any_p no_p @ The following function returns an integer value, namely the number of particles for which the condition is true. If there is no condition, it returns simply the length of the subevent. <>= subroutine count_a (ival, en1, en0) integer, intent(out) :: ival type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 integer :: i, n, count n = subevt_get_length (en1%pval) if (present (en0)) then count = 0 do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) if (en0%lval) count = count + 1 end do ival = count else ival = n end if end subroutine count_a @ %def count_a @ \subsubsection{Binary particle-list functions} This joins two subevents, stored in the evaluation nodes [[en1]] and [[en2]]. If [[en0]] is also present, it amounts to a logical test returning true or false for every pair of particles. A particle of the second list gets a mask entry only if it passes the test for all particles of the first list. <>= subroutine join_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask2 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) allocate (mask2 (n2)) mask2 = .true. if (present (en0)) then do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) call eval_node_evaluate (en0) mask2(j) = mask2(j) .and. en0%lval end do end do end if call subevt_join (subevt, en1%pval, en2%pval, mask2) end subroutine join_pp @ %def join_pp @ Combine two subevents, i.e., make a list of composite particles built from all possible particle pairs from the two lists. If [[en0]] is present, create a mask which is true only for those pairs that pass the test. <>= subroutine combine_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:,:), allocatable :: mask12 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) if (present (en0)) then allocate (mask12 (n1, n2)) do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) call eval_node_evaluate (en0) mask12(i,j) = en0%lval end do end do call subevt_combine (subevt, en1%pval, en2%pval, mask12) else call subevt_combine (subevt, en1%pval, en2%pval) end if end subroutine combine_pp @ %def combine_pp @ Combine all particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test w.r.t. all particles in the second argument. If [[en0]] is absent, the second argument is ignored. <>= subroutine collect_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) allocate (mask1 (n1)) mask1 = .true. if (present (en0)) then do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) call eval_node_evaluate (en0) mask1(i) = mask1(i) .and. en0%lval end do end do end if call subevt_collect (subevt, en1%pval, mask1) end subroutine collect_pp @ %def collect_pp @ Select all particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test w.r.t. all particles in the second argument. If [[en0]] is absent, the second argument is ignored, and the first argument is transferred unchanged. (This case is not very useful, of course.) <>= subroutine select_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) allocate (mask1 (n1)) mask1 = .true. if (present (en0)) then do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) call eval_node_evaluate (en0) mask1(i) = mask1(i) .and. en0%lval end do end do end if call subevt_select (subevt, en1%pval, mask1) end subroutine select_pp @ %def select_pp @ Sort the first subevent according to the result of evaluating [[en0]]. From the second subevent, only the first element is taken as reference. If [[en0]] is absent, we sort by default method (PDG code, particles before antiparticles). <>= subroutine sort_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 integer, dimension(:), allocatable :: ival real(default), dimension(:), allocatable :: rval integer :: i, n1 n1 = subevt_get_length (en1%pval) if (present (en0)) then select case (en0%result_type) case (V_INT); allocate (ival (n1)) case (V_REAL); allocate (rval (n1)) end select do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) en0%prt2 = subevt_get_prt (en2%pval, 1) call eval_node_evaluate (en0) select case (en0%result_type) case (V_INT); ival(i) = en0%ival case (V_REAL); rval(i) = en0%rval end select end do select case (en0%result_type) case (V_INT); call subevt_sort (subevt, en1%pval, ival) case (V_REAL); call subevt_sort (subevt, en1%pval, rval) end select else call subevt_sort (subevt, en1%pval) end if end subroutine sort_pp @ %def sort_pp @ The following functions return a logical value. [[all]] evaluates to true if the condition [[en0]] is true for all valid element pairs of both subevents. Invalid pairs (with common [[src]] entry) are ignored. [[any]] and [[no]] are analogous. <>= function all_pp (en1, en2, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) lval = .true. LOOP1: do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) lval = en0%lval if (.not. lval) exit LOOP1 end if end do end do LOOP1 end function all_pp function any_pp (en1, en2, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) lval = .false. LOOP1: do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) lval = en0%lval if (lval) exit LOOP1 end if end do end do LOOP1 end function any_pp function no_pp (en1, en2, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) lval = .true. LOOP1: do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) lval = .not. en0%lval if (lval) exit LOOP1 end if end do end do LOOP1 end function no_pp @ %def all_pp any_pp no_pp The conditional restriction encoded in the [[eval_node_t]] [[en_0]] is applied only to the photons from [[en1]], not to the objects being isolated from in [[en2]]. <>= function photon_isolation_pp (en1, en2, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 type(prt_t) :: prt type(prt_t), dimension(:), allocatable :: prt_gam0, prt_lep type(vector4_t), dimension(:), allocatable :: & p_gam0, p_lep0, p_lep, p_par integer :: i, j, n1, n2, n_par, n_lep, n_gam, n_delta real(default), dimension(:), allocatable :: delta_r, et_sum integer, dimension(:), allocatable :: index real(default) :: eps, iso_n, r0, pt_gam logical, dimension(:,:), allocatable :: photon_mask n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) allocate (p_gam0 (n1), prt_gam0 (n1)) eps = en1%photon_iso_eps iso_n = en1%photon_iso_n r0 = en1%photon_iso_r0 lval = .true. do i = 1, n1 en0%index = i prt = subevt_get_prt (en1%pval, i) prt_gam0(i) = prt if (.not. prt_is_photon (prt_gam0(i))) & call msg_fatal ("Photon isolation can only " // & "be applied to photons.") p_gam0(i) = prt_get_momentum (prt_gam0(i)) en0%prt1 = prt call eval_node_evaluate (en0) lval = en0%lval if (.not. lval) return end do if (n1 == 0) then call msg_fatal ("Photon isolation applied on empty photon sample.") end if n_par = 0 n_lep = 0 n_gam = 0 do i = 1, n2 prt = subevt_get_prt (en2%pval, i) if (prt_is_parton (prt) .or. prt_is_clustered (prt)) then n_par = n_par + 1 end if if (prt_is_lepton (prt)) then n_lep = n_lep + 1 end if if (prt_is_photon (prt)) then n_gam = n_gam + 1 end if end do if (n_lep > 0 .and. n_gam == 0) then call msg_fatal ("Photon isolation from EM energy: photons " // & "have to be included.") end if if (n_lep > 0 .and. n_gam /= n1) then call msg_fatal ("Photon isolation: photon samples do not match.") end if allocate (p_par (n_par)) allocate (p_lep0 (n_gam+n_lep), prt_lep(n_gam+n_lep)) n_par = 0 n_lep = 0 do i = 1, n2 prt = subevt_get_prt (en2%pval, i) if (prt_is_parton (prt) .or. prt_is_clustered (prt)) then n_par = n_par + 1 p_par(n_par) = prt_get_momentum (prt) end if if (prt_is_lepton (prt) .or. prt_is_photon(prt)) then n_lep = n_lep + 1 prt_lep(n_lep) = prt p_lep0(n_lep) = prt_get_momentum (prt_lep(n_lep)) end if end do if (n_par > 0) then allocate (delta_r (n_par), index (n_par)) HADRON_ISOLATION: do i = 1, n1 pt_gam = transverse_part (p_gam0(i)) delta_r(1:n_par) = sort (eta_phi_distance (p_gam0(i), p_par(1:n_par))) index(1:n_par) = order (eta_phi_distance (p_gam0(i), p_par(1:n_par))) n_delta = count (delta_r < r0) allocate (et_sum(n_delta)) do j = 1, n_delta et_sum(j) = sum (transverse_part (p_par (index (1:j)))) if (.not. et_sum(j) <= & iso_chi_gamma (delta_r(j), r0, iso_n, eps, pt_gam)) then lval = .false. return end if end do deallocate (et_sum) end do HADRON_ISOLATION deallocate (delta_r) deallocate (index) end if if (n_lep > 0) then allocate (photon_mask(n1,n_lep)) do i = 1, n1 photon_mask(i,:) = .not. (prt_gam0(i) .match. prt_lep(:)) end do allocate (delta_r (n_lep-1), index (n_lep-1), p_lep(n_lep-1)) EM_ISOLATION: do i = 1, n1 pt_gam = transverse_part (p_gam0(i)) p_lep = pack (p_lep0, photon_mask(i,:)) delta_r(1:n_lep-1) = sort (eta_phi_distance (p_gam0(i), p_lep(1:n_lep-1))) index(1:n_lep-1) = order (eta_phi_distance (p_gam0(i), p_lep(1:n_lep-1))) n_delta = count (delta_r < r0) allocate (et_sum(n_delta)) do j = 1, n_delta et_sum(j) = sum (transverse_part (p_lep (index(1:j)))) if (.not. et_sum(j) <= & iso_chi_gamma (delta_r(j), r0, iso_n, eps, pt_gam)) then lval = .false. return end if end do deallocate (et_sum) end do EM_ISOLATION deallocate (delta_r) deallocate (index) end if contains function iso_chi_gamma (dr, r0_gam, n_gam, eps_gam, pt_gam) result (iso) real(default) :: iso real(default), intent(in) :: dr, r0_gam, n_gam, eps_gam, pt_gam iso = eps_gam * pt_gam if (.not. nearly_equal (abs(n_gam), 0._default)) then iso = iso * ((1._default - cos(dr)) / & (1._default - cos(r0_gam)))**abs(n_gam) end if end function iso_chi_gamma end function photon_isolation_pp @ %def photon_isolation_pp @ This function evaluates an observable for a pair of particles. From the two particle lists, we take the first pair without [[src]] overlap. If there is no valid pair, we revert the status of the value to unknown. <>= subroutine eval_pp (en1, en2, en0, rval, is_known) type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 real(default), intent(out) :: rval logical, intent(out) :: is_known integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) rval = 0 is_known = .false. LOOP1: do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) rval = en0%rval is_known = .true. exit LOOP1 end if end do end do LOOP1 end subroutine eval_pp @ %def eval_ppp @ The following function returns an integer value, namely the number of valid particle-pairs from both lists for which the condition is true. Invalid pairs (with common [[src]] entry) are ignored. If there is no condition, it returns the number of valid particle pairs. <>= subroutine count_pp (ival, en1, en2, en0) integer, intent(out) :: ival type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 integer :: i, j, n1, n2, count n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) if (present (en0)) then count = 0 do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) if (en0%lval) count = count + 1 end if end do end do else count = 0 do i = 1, n1 do j = 1, n2 if (are_disjoint (subevt_get_prt (en1%pval, i), & subevt_get_prt (en2%pval, j))) then count = count + 1 end if end do end do end if ival = count end subroutine count_pp @ %def count_pp @ This function makes up a subevent from the second argument which consists only of particles which match the PDG code array (first argument). <>= subroutine select_pdg_ca (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 if (present (en0)) then call subevt_select_pdg_code (subevt, en1%aval, en2%pval, en0%ival) else call subevt_select_pdg_code (subevt, en1%aval, en2%pval) end if end subroutine select_pdg_ca @ %def select_pdg_ca @ \subsubsection{Binary string functions} Currently, the only string operation is concatenation. <>= subroutine concat_ss (string, en1, en2) type(string_t), intent(out) :: string type(eval_node_t), intent(in) :: en1, en2 string = en1%sval // en2%sval end subroutine concat_ss @ %def concat_ss @ \subsection{Compiling the parse tree} The evaluation tree is built recursively by following a parse tree. Evaluate an expression. The requested type is given as an optional argument; default is numeric (integer or real). <>= recursive subroutine eval_node_compile_genexpr & (en, pn, var_list, result_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: result_type if (debug_active (D_MODEL_F)) then print *, "read genexpr"; call parse_node_write (pn) end if if (present (result_type)) then select case (result_type) case (V_INT, V_REAL, V_CMPLX) call eval_node_compile_expr (en, pn, var_list) case (V_LOG) call eval_node_compile_lexpr (en, pn, var_list) case (V_SEV) call eval_node_compile_pexpr (en, pn, var_list) case (V_PDG) call eval_node_compile_cexpr (en, pn, var_list) case (V_STR) call eval_node_compile_sexpr (en, pn, var_list) end select else call eval_node_compile_expr (en, pn, var_list) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done genexpr" end if end subroutine eval_node_compile_genexpr @ %def eval_node_compile_genexpr @ \subsubsection{Numeric expressions} This procedure compiles a numerical expression. This is a single term or a sum or difference of terms. We have to account for all combinations of integer and real arguments. If both are constant, we immediately do the calculation and allocate a constant node. <>= recursive subroutine eval_node_compile_expr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_term, pn_addition, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(string_t) :: key integer :: t1, t2, t if (debug_active (D_MODEL_F)) then print *, "read expr"; call parse_node_write (pn) end if pn_term => parse_node_get_sub_ptr (pn) select case (char (parse_node_get_rule_key (pn_term))) case ("term") call eval_node_compile_term (en, pn_term, var_list) pn_addition => parse_node_get_next_ptr (pn_term, tag="addition") case ("addition") en => null () pn_addition => pn_term case default call parse_node_mismatch ("term|addition", pn) end select do while (associated (pn_addition)) pn_op => parse_node_get_sub_ptr (pn_addition) pn_arg => parse_node_get_next_ptr (pn_op, tag="term") call eval_node_compile_term (en2, pn_arg, var_list) t2 = en2%result_type if (associated (en)) then en1 => en t1 = en1%result_type else allocate (en1) select case (t2) case (V_INT); call eval_node_init_int (en1, 0) case (V_REAL); call eval_node_init_real (en1, 0._default) case (V_CMPLX); call eval_node_init_cmplx (en1, cmplx & (0._default, 0._default, kind=default)) end select t1 = t2 end if t = numeric_result_type (t1, t2) allocate (en) key = parse_node_get_key (pn_op) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then select case (char (key)) case ("+") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, add_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, add_ir (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, add_ic (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, add_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, add_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, add_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, add_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, add_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, add_cc (en1, en2)) end select end select case ("-") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, sub_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, sub_ir (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, sub_ic (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, sub_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, sub_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, sub_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, sub_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, sub_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, sub_cc (en1, en2)) end select end select end select call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch (en, key, t, en1, en2) select case (char (key)) case ("+") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, add_ii) case (V_REAL); call eval_node_set_op2_real (en, add_ir) case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_ic) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, add_ri) case (V_REAL); call eval_node_set_op2_real (en, add_rr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_rc) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, add_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, add_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_cc) end select end select case ("-") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, sub_ii) case (V_REAL); call eval_node_set_op2_real (en, sub_ir) case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_ic) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, sub_ri) case (V_REAL); call eval_node_set_op2_real (en, sub_rr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_rc) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, sub_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, sub_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_cc) end select end select end select end if pn_addition => parse_node_get_next_ptr (pn_addition) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done expr" end if end subroutine eval_node_compile_expr @ %def eval_node_compile_expr <>= recursive subroutine eval_node_compile_term (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_factor, pn_multiplication, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(string_t) :: key integer :: t1, t2, t if (debug_active (D_MODEL_F)) then print *, "read term"; call parse_node_write (pn) end if pn_factor => parse_node_get_sub_ptr (pn, tag="factor") call eval_node_compile_factor (en, pn_factor, var_list) pn_multiplication => & parse_node_get_next_ptr (pn_factor, tag="multiplication") do while (associated (pn_multiplication)) pn_op => parse_node_get_sub_ptr (pn_multiplication) pn_arg => parse_node_get_next_ptr (pn_op, tag="factor") en1 => en call eval_node_compile_factor (en2, pn_arg, var_list) t1 = en1%result_type t2 = en2%result_type t = numeric_result_type (t1, t2) allocate (en) key = parse_node_get_key (pn_op) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then select case (char (key)) case ("*") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, mul_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, mul_ir (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, mul_ic (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, mul_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, mul_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, mul_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, mul_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, mul_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, mul_cc (en1, en2)) end select end select case ("/") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, div_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, div_ir (en1, en2)) case (V_CMPLX); call eval_node_init_real (en, div_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, div_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, div_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, div_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, div_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, div_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, div_cc (en1, en2)) end select end select end select call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch (en, key, t, en1, en2) select case (char (key)) case ("*") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, mul_ii) case (V_REAL); call eval_node_set_op2_real (en, mul_ir) case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_ic) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, mul_ri) case (V_REAL); call eval_node_set_op2_real (en, mul_rr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_rc) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, mul_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, mul_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_cc) end select end select case ("/") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, div_ii) case (V_REAL); call eval_node_set_op2_real (en, div_ir) case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_ic) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, div_ri) case (V_REAL); call eval_node_set_op2_real (en, div_rr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_rc) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, div_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, div_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_cc) end select end select end select end if pn_multiplication => parse_node_get_next_ptr (pn_multiplication) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done term" end if end subroutine eval_node_compile_term @ %def eval_node_compile_term <>= recursive subroutine eval_node_compile_factor (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_value, pn_exponentiation, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(string_t) :: key integer :: t1, t2, t if (debug_active (D_MODEL_F)) then print *, "read factor"; call parse_node_write (pn) end if pn_value => parse_node_get_sub_ptr (pn) call eval_node_compile_signed_value (en, pn_value, var_list) pn_exponentiation => & parse_node_get_next_ptr (pn_value, tag="exponentiation") if (associated (pn_exponentiation)) then pn_op => parse_node_get_sub_ptr (pn_exponentiation) pn_arg => parse_node_get_next_ptr (pn_op) en1 => en call eval_node_compile_signed_value (en2, pn_arg, var_list) t1 = en1%result_type t2 = en2%result_type t = numeric_result_type (t1, t2) allocate (en) key = parse_node_get_key (pn_op) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, pow_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, pow_ir (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, pow_ic (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, pow_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, pow_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, pow_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, pow_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, pow_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, pow_cc (en1, en2)) end select end select call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch (en, key, t, en1, en2) select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, pow_ii) case (V_REAL,V_CMPLX); call eval_type_error (pn, "exponentiation", t1) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, pow_ri) case (V_REAL); call eval_node_set_op2_real (en, pow_rr) case (V_CMPLX); call eval_type_error (pn, "exponentiation", t1) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, pow_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, pow_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, pow_cc) end select end select end if end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done factor" end if end subroutine eval_node_compile_factor @ %def eval_node_compile_factor <>= recursive subroutine eval_node_compile_signed_value (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_arg type(eval_node_t), pointer :: en1 integer :: t if (debug_active (D_MODEL_F)) then print *, "read signed value"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("signed_value") pn_arg => parse_node_get_sub_ptr (pn, 2) call eval_node_compile_value (en1, pn_arg, var_list) t = en1%result_type allocate (en) if (en1%type == EN_CONSTANT) then select case (t) case (V_INT); call eval_node_init_int (en, neg_i (en1)) case (V_REAL); call eval_node_init_real (en, neg_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, neg_c (en1)) end select call eval_node_final_rec (en1) deallocate (en1) else call eval_node_init_branch (en, var_str ("-"), t, en1) select case (t) case (V_INT); call eval_node_set_op1_int (en, neg_i) case (V_REAL); call eval_node_set_op1_real (en, neg_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, neg_c) end select end if case default call eval_node_compile_value (en, pn, var_list) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done signed value" end if end subroutine eval_node_compile_signed_value @ %def eval_node_compile_signed_value @ Integer, real and complex values have an optional unit. The unit is extracted and applied immediately. An integer with unit evaluates to a real constant. <>= recursive subroutine eval_node_compile_value (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list if (debug_active (D_MODEL_F)) then print *, "read value"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("integer_value", "real_value", "complex_value") call eval_node_compile_numeric_value (en, pn) case ("pi") call eval_node_compile_constant (en, pn) case ("I") call eval_node_compile_constant (en, pn) case ("variable") call eval_node_compile_variable (en, pn, var_list) case ("result") call eval_node_compile_result (en, pn, var_list) case ("expr") call eval_node_compile_expr (en, pn, var_list) case ("block_expr") call eval_node_compile_block_expr (en, pn, var_list) case ("conditional_expr") call eval_node_compile_conditional (en, pn, var_list) case ("unary_function") call eval_node_compile_unary_function (en, pn, var_list) case ("binary_function") call eval_node_compile_binary_function (en, pn, var_list) case ("eval_fun") call eval_node_compile_eval_function (en, pn, var_list) case ("count_fun") call eval_node_compile_numeric_function (en, pn, var_list) case default call parse_node_mismatch & ("integer|real|complex|constant|variable|" // & "expr|block_expr|conditional_expr|" // & "unary_function|binary_function|numeric_pexpr", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done value" end if end subroutine eval_node_compile_value @ %def eval_node_compile_value @ Real, complex and integer values are numeric literals with an optional unit attached. In case of an integer, the unit actually makes it a real value in disguise. The signed version of real values is not possible in generic expressions; it is a special case for numeric constants in model files (see below). We do not introduce signed versions of complex values. <>= subroutine eval_node_compile_numeric_value (en, pn) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(parse_node_t), pointer :: pn_val, pn_unit allocate (en) pn_val => parse_node_get_sub_ptr (pn) pn_unit => parse_node_get_next_ptr (pn_val) select case (char (parse_node_get_rule_key (pn))) case ("integer_value") if (associated (pn_unit)) then call eval_node_init_real (en, & parse_node_get_integer (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_int (en, parse_node_get_integer (pn_val)) end if case ("real_value") if (associated (pn_unit)) then call eval_node_init_real (en, & parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_real (en, parse_node_get_real (pn_val)) end if case ("complex_value") if (associated (pn_unit)) then call eval_node_init_cmplx (en, & parse_node_get_cmplx (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_cmplx (en, parse_node_get_cmplx (pn_val)) end if case ("neg_real_value") pn_val => parse_node_get_sub_ptr (parse_node_get_sub_ptr (pn, 2)) pn_unit => parse_node_get_next_ptr (pn_val) if (associated (pn_unit)) then call eval_node_init_real (en, & - parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_real (en, - parse_node_get_real (pn_val)) end if case ("pos_real_value") pn_val => parse_node_get_sub_ptr (parse_node_get_sub_ptr (pn, 2)) pn_unit => parse_node_get_next_ptr (pn_val) if (associated (pn_unit)) then call eval_node_init_real (en, & parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_real (en, parse_node_get_real (pn_val)) end if case default call parse_node_mismatch & ("integer_value|real_value|complex_value|neg_real_value|pos_real_value", pn) end select end subroutine eval_node_compile_numeric_value @ %def eval_node_compile_numeric_value @ These are the units, predefined and hardcoded. The default energy unit is GeV, the default angular unit is radians. We include units for observables of dimension energy squared. Luminosities are normalized in inverse femtobarns. <>= function parse_node_get_unit (pn) result (factor) real(default) :: factor real(default) :: unit type(parse_node_t), intent(in) :: pn type(parse_node_t), pointer :: pn_unit, pn_unit_power type(parse_node_t), pointer :: pn_frac, pn_num, pn_int, pn_div, pn_den integer :: num, den pn_unit => parse_node_get_sub_ptr (pn) select case (char (parse_node_get_key (pn_unit))) case ("TeV"); unit = 1.e3_default case ("GeV"); unit = 1 case ("MeV"); unit = 1.e-3_default case ("keV"); unit = 1.e-6_default case ("eV"); unit = 1.e-9_default case ("meV"); unit = 1.e-12_default case ("nbarn"); unit = 1.e6_default case ("pbarn"); unit = 1.e3_default case ("fbarn"); unit = 1 case ("abarn"); unit = 1.e-3_default case ("rad"); unit = 1 case ("mrad"); unit = 1.e-3_default case ("degree"); unit = degree case ("%"); unit = 1.e-2_default case default call msg_bug (" Unit '" // & char (parse_node_get_key (pn)) // "' is undefined.") end select pn_unit_power => parse_node_get_next_ptr (pn_unit) if (associated (pn_unit_power)) then pn_frac => parse_node_get_sub_ptr (pn_unit_power, 2) pn_num => parse_node_get_sub_ptr (pn_frac) select case (char (parse_node_get_rule_key (pn_num))) case ("neg_int") pn_int => parse_node_get_sub_ptr (pn_num, 2) num = - parse_node_get_integer (pn_int) case ("pos_int") pn_int => parse_node_get_sub_ptr (pn_num, 2) num = parse_node_get_integer (pn_int) case ("integer_literal") num = parse_node_get_integer (pn_num) case default call parse_node_mismatch ("neg_int|pos_int|integer_literal", pn_num) end select pn_div => parse_node_get_next_ptr (pn_num) if (associated (pn_div)) then pn_den => parse_node_get_sub_ptr (pn_div, 2) den = parse_node_get_integer (pn_den) else den = 1 end if else num = 1 den = 1 end if factor = unit ** (real (num, default) / den) end function parse_node_get_unit @ %def parse_node_get_unit @ There are only two predefined constants, but more can be added easily. <>= subroutine eval_node_compile_constant (en, pn) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn if (debug_active (D_MODEL_F)) then print *, "read constant"; call parse_node_write (pn) end if allocate (en) select case (char (parse_node_get_key (pn))) case ("pi"); call eval_node_init_real (en, pi) case ("I"); call eval_node_init_cmplx (en, imago) case default call parse_node_mismatch ("pi or I", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done constant" end if end subroutine eval_node_compile_constant @ %def eval_node_compile_constant @ Compile a variable, with or without a specified type. Take the list of variables, look for the name and make a node with a pointer to the value. If no type is provided, the variable is numeric, and the stored value determines whether it is real or integer. We explicitly demand that the variable is defined, so we do not accidentally point to variables that are declared only later in the script but have come into existence in a previous compilation pass. Variables may actually be anonymous, these are expressions in disguise. In that case, the expression replaces the variable name in the parse tree, and we allocate an ordinary expression node in the eval tree. Variables of type [[V_PDG]] (pdg-code array) are not treated here. They are handled by [[eval_node_compile_cvariable]]. <>= recursive subroutine eval_node_compile_variable (en, pn, var_list, var_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: var_type type(parse_node_t), pointer :: pn_name type(string_t) :: var_name logical, target, save :: no_lval real(default), target, save :: no_rval type(subevt_t), target, save :: no_pval type(string_t), target, save :: no_sval logical, target, save :: unknown = .false. integer :: type logical :: defined logical, pointer :: known logical, pointer :: lptr integer, pointer :: iptr real(default), pointer :: rptr complex(default), pointer :: cptr type(subevt_t), pointer :: pptr type(string_t), pointer :: sptr procedure(obs_unary_int), pointer :: obs1_iptr procedure(obs_unary_real), pointer :: obs1_rptr procedure(obs_binary_int), pointer :: obs2_iptr procedure(obs_binary_real), pointer :: obs2_rptr type(prt_t), pointer :: p1, p2 if (debug_active (D_MODEL_F)) then print *, "read variable"; call parse_node_write (pn) end if if (present (var_type)) then select case (var_type) case (V_REAL, V_OBS1_REAL, V_OBS2_REAL, V_INT, V_OBS1_INT, & V_OBS2_INT, V_CMPLX) pn_name => pn case default pn_name => parse_node_get_sub_ptr (pn, 2) end select else pn_name => pn end if select case (char (parse_node_get_rule_key (pn_name))) case ("expr") call eval_node_compile_expr (en, pn_name, var_list) case ("lexpr") call eval_node_compile_lexpr (en, pn_name, var_list) case ("sexpr") call eval_node_compile_sexpr (en, pn_name, var_list) case ("pexpr") call eval_node_compile_pexpr (en, pn_name, var_list) case ("variable") var_name = parse_node_get_string (pn_name) if (present (var_type)) then select case (var_type) case (V_LOG); var_name = "?" // var_name case (V_SEV); var_name = "@" // var_name case (V_STR); var_name = "$" // var_name ! $ sign end select end if call var_list%get_var_properties & (var_name, req_type=var_type, type=type, is_defined=defined) allocate (en) if (defined) then select case (type) case (V_LOG) call var_list%get_lptr (var_name, lptr, known) call eval_node_init_log_ptr (en, var_name, lptr, known) case (V_INT) call var_list%get_iptr (var_name, iptr, known) call eval_node_init_int_ptr (en, var_name, iptr, known) case (V_REAL) call var_list%get_rptr (var_name, rptr, known) call eval_node_init_real_ptr (en, var_name, rptr, known) case (V_CMPLX) call var_list%get_cptr (var_name, cptr, known) call eval_node_init_cmplx_ptr (en, var_name, cptr, known) case (V_SEV) call var_list%get_pptr (var_name, pptr, known) call eval_node_init_subevt_ptr (en, var_name, pptr, known) case (V_STR) call var_list%get_sptr (var_name, sptr, known) call eval_node_init_string_ptr (en, var_name, sptr, known) case (V_OBS1_INT) call var_list%get_obs1_iptr (var_name, obs1_iptr, p1) call eval_node_init_obs1_int_ptr (en, var_name, obs1_iptr, p1) case (V_OBS2_INT) call var_list%get_obs2_iptr (var_name, obs2_iptr, p1, p2) call eval_node_init_obs2_int_ptr (en, var_name, obs2_iptr, p1, p2) case (V_OBS1_REAL) call var_list%get_obs1_rptr (var_name, obs1_rptr, p1) call eval_node_init_obs1_real_ptr (en, var_name, obs1_rptr, p1) case (V_OBS2_REAL) call var_list%get_obs2_rptr (var_name, obs2_rptr, p1, p2) call eval_node_init_obs2_real_ptr (en, var_name, obs2_rptr, p1, p2) case default call parse_node_write (pn) call msg_fatal ("Variable of this type " // & "is not allowed in the present context") if (present (var_type)) then select case (var_type) case (V_LOG) call eval_node_init_log_ptr (en, var_name, no_lval, unknown) case (V_SEV) call eval_node_init_subevt_ptr & (en, var_name, no_pval, unknown) case (V_STR) call eval_node_init_string_ptr & (en, var_name, no_sval, unknown) end select else call eval_node_init_real_ptr (en, var_name, no_rval, unknown) end if end select else call parse_node_write (pn) call msg_error ("This variable is undefined at this point") if (present (var_type)) then select case (var_type) case (V_LOG) call eval_node_init_log_ptr (en, var_name, no_lval, unknown) case (V_SEV) call eval_node_init_subevt_ptr & (en, var_name, no_pval, unknown) case (V_STR) call eval_node_init_string_ptr (en, var_name, no_sval, unknown) end select else call eval_node_init_real_ptr (en, var_name, no_rval, unknown) end if end if end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done variable" end if end subroutine eval_node_compile_variable @ %def eval_node_compile_variable @ In a given context, a variable has to have a certain type. <>= subroutine check_var_type (pn, ok, type_actual, type_requested) type(parse_node_t), intent(in) :: pn logical, intent(out) :: ok integer, intent(in) :: type_actual integer, intent(in), optional :: type_requested if (present (type_requested)) then select case (type_requested) case (V_LOG) select case (type_actual) case (V_LOG) case default call parse_node_write (pn) call msg_fatal ("Variable type is invalid (should be logical)") ok = .false. end select case (V_SEV) select case (type_actual) case (V_SEV) case default call parse_node_write (pn) call msg_fatal & ("Variable type is invalid (should be particle set)") ok = .false. end select case (V_PDG) select case (type_actual) case (V_PDG) case default call parse_node_write (pn) call msg_fatal & ("Variable type is invalid (should be PDG array)") ok = .false. end select case (V_STR) select case (type_actual) case (V_STR) case default call parse_node_write (pn) call msg_fatal & ("Variable type is invalid (should be string)") ok = .false. end select case default call parse_node_write (pn) call msg_bug ("Variable type is unknown") end select else select case (type_actual) case (V_REAL, V_OBS1_REAL, V_OBS2_REAL, V_INT, V_OBS1_INT, & V_OBS2_INT, V_CMPLX) case default call parse_node_write (pn) call msg_fatal ("Variable type is invalid (should be numeric)") ok = .false. end select end if ok = .true. end subroutine check_var_type @ %def check_var_type @ Retrieve the result of an integration. If the requested process has been integrated, the results are available as special variables. (The variables cannot be accessed in the usual way since they contain brackets in their names.) Since this compilation step may occur before the processes have been loaded, we have to initialize the required variables before they are used. <>= subroutine eval_node_compile_result (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_key, pn_prc_id type(string_t) :: key, prc_id, var_name integer, pointer :: iptr real(default), pointer :: rptr logical, pointer :: known if (debug_active (D_MODEL_F)) then print *, "read result"; call parse_node_write (pn) end if pn_key => parse_node_get_sub_ptr (pn) pn_prc_id => parse_node_get_next_ptr (pn_key) key = parse_node_get_key (pn_key) prc_id = parse_node_get_string (pn_prc_id) var_name = key // "(" // prc_id // ")" if (var_list%contains (var_name)) then allocate (en) select case (char(key)) case ("num_id", "n_calls") call var_list%get_iptr (var_name, iptr, known) call eval_node_init_int_ptr (en, var_name, iptr, known) case ("integral", "error") call var_list%get_rptr (var_name, rptr, known) call eval_node_init_real_ptr (en, var_name, rptr, known) end select else call msg_fatal ("Result variable '" // char (var_name) & // "' is undefined (call 'integrate' before use)") end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done result" end if end subroutine eval_node_compile_result @ %def eval_node_compile_result @ Functions with a single argument. For non-constant arguments, watch for functions which convert their argument to a different type. <>= recursive subroutine eval_node_compile_unary_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_fname, pn_arg type(eval_node_t), pointer :: en1 type(string_t) :: key integer :: t if (debug_active (D_MODEL_F)) then print *, "read unary function"; call parse_node_write (pn) end if pn_fname => parse_node_get_sub_ptr (pn) pn_arg => parse_node_get_next_ptr (pn_fname, tag="function_arg1") call eval_node_compile_expr & (en1, parse_node_get_sub_ptr (pn_arg, tag="expr"), var_list) t = en1%result_type allocate (en) key = parse_node_get_key (pn_fname) if (en1%type == EN_CONSTANT) then select case (char (key)) case ("complex") select case (t) case (V_INT); call eval_node_init_cmplx (en, cmplx_i (en1)) case (V_REAL); call eval_node_init_cmplx (en, cmplx_r (en1)) case (V_CMPLX); deallocate (en); en => en1; en1 => null () case default; call eval_type_error (pn, char (key), t) end select case ("real") select case (t) case (V_INT); call eval_node_init_real (en, real_i (en1)) case (V_REAL); deallocate (en); en => en1; en1 => null () case (V_CMPLX); call eval_node_init_real (en, real_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("int") select case (t) case (V_INT); deallocate (en); en => en1; en1 => null () case (V_REAL); call eval_node_init_int (en, int_r (en1)) case (V_CMPLX); call eval_node_init_int (en, int_c (en1)) end select case ("nint") select case (t) case (V_INT); deallocate (en); en => en1; en1 => null () case (V_REAL); call eval_node_init_int (en, nint_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("floor") select case (t) case (V_INT); deallocate (en); en => en1; en1 => null () case (V_REAL); call eval_node_init_int (en, floor_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("ceiling") select case (t) case (V_INT); deallocate (en); en => en1; en1 => null () case (V_REAL); call eval_node_init_int (en, ceiling_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("abs") select case (t) case (V_INT); call eval_node_init_int (en, abs_i (en1)) case (V_REAL); call eval_node_init_real (en, abs_r (en1)) case (V_CMPLX); call eval_node_init_real (en, abs_c (en1)) end select case ("conjg") select case (t) case (V_INT); call eval_node_init_int (en, conjg_i (en1)) case (V_REAL); call eval_node_init_real (en, conjg_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, conjg_c (en1)) end select case ("sgn") select case (t) case (V_INT); call eval_node_init_int (en, sgn_i (en1)) case (V_REAL); call eval_node_init_real (en, sgn_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("sqrt") select case (t) case (V_REAL); call eval_node_init_real (en, sqrt_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, sqrt_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("exp") select case (t) case (V_REAL); call eval_node_init_real (en, exp_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, exp_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("log") select case (t) case (V_REAL); call eval_node_init_real (en, log_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, log_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("log10") select case (t) case (V_REAL); call eval_node_init_real (en, log10_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("sin") select case (t) case (V_REAL); call eval_node_init_real (en, sin_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, sin_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("cos") select case (t) case (V_REAL); call eval_node_init_real (en, cos_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, cos_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("tan") select case (t) case (V_REAL); call eval_node_init_real (en, tan_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("asin") select case (t) case (V_REAL); call eval_node_init_real (en, asin_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("acos") select case (t) case (V_REAL); call eval_node_init_real (en, acos_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("atan") select case (t) case (V_REAL); call eval_node_init_real (en, atan_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("sinh") select case (t) case (V_REAL); call eval_node_init_real (en, sinh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("cosh") select case (t) case (V_REAL); call eval_node_init_real (en, cosh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("tanh") select case (t) case (V_REAL); call eval_node_init_real (en, tanh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("asinh") select case (t) case (V_REAL); call eval_node_init_real (en, asinh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("acosh") select case (t) case (V_REAL); call eval_node_init_real (en, acosh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("atanh") select case (t) case (V_REAL); call eval_node_init_real (en, atanh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case default call parse_node_mismatch ("function name", pn_fname) end select if (associated (en1)) then call eval_node_final_rec (en1) deallocate (en1) end if else select case (char (key)) case ("complex") call eval_node_init_branch (en, key, V_CMPLX, en1) case ("real") call eval_node_init_branch (en, key, V_REAL, en1) case ("int", "nint", "floor", "ceiling") call eval_node_init_branch (en, key, V_INT, en1) case default call eval_node_init_branch (en, key, t, en1) end select select case (char (key)) case ("complex") select case (t) case (V_INT); call eval_node_set_op1_cmplx (en, cmplx_i) case (V_REAL); call eval_node_set_op1_cmplx (en, cmplx_r) case (V_CMPLX); deallocate (en); en => en1 case default; call eval_type_error (pn, char (key), t) end select case ("real") select case (t) case (V_INT); call eval_node_set_op1_real (en, real_i) case (V_REAL); deallocate (en); en => en1 case (V_CMPLX); call eval_node_set_op1_real (en, real_c) case default; call eval_type_error (pn, char (key), t) end select case ("int") select case (t) case (V_INT); deallocate (en); en => en1 case (V_REAL); call eval_node_set_op1_int (en, int_r) case (V_CMPLX); call eval_node_set_op1_int (en, int_c) end select case ("nint") select case (t) case (V_INT); deallocate (en); en => en1 case (V_REAL); call eval_node_set_op1_int (en, nint_r) case default; call eval_type_error (pn, char (key), t) end select case ("floor") select case (t) case (V_INT); deallocate (en); en => en1 case (V_REAL); call eval_node_set_op1_int (en, floor_r) case default; call eval_type_error (pn, char (key), t) end select case ("ceiling") select case (t) case (V_INT); deallocate (en); en => en1 case (V_REAL); call eval_node_set_op1_int (en, ceiling_r) case default; call eval_type_error (pn, char (key), t) end select case ("abs") select case (t) case (V_INT); call eval_node_set_op1_int (en, abs_i) case (V_REAL); call eval_node_set_op1_real (en, abs_r) case (V_CMPLX); call eval_node_init_branch (en, key, V_REAL, en1) call eval_node_set_op1_real (en, abs_c) end select case ("conjg") select case (t) case (V_INT); call eval_node_set_op1_int (en, conjg_i) case (V_REAL); call eval_node_set_op1_real (en, conjg_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, conjg_c) end select case ("sgn") select case (t) case (V_INT); call eval_node_set_op1_int (en, sgn_i) case (V_REAL); call eval_node_set_op1_real (en, sgn_r) case default; call eval_type_error (pn, char (key), t) end select case ("sqrt") select case (t) case (V_REAL); call eval_node_set_op1_real (en, sqrt_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, sqrt_c) case default; call eval_type_error (pn, char (key), t) end select case ("exp") select case (t) case (V_REAL); call eval_node_set_op1_real (en, exp_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, exp_c) case default; call eval_type_error (pn, char (key), t) end select case ("log") select case (t) case (V_REAL); call eval_node_set_op1_real (en, log_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, log_c) case default; call eval_type_error (pn, char (key), t) end select case ("log10") select case (t) case (V_REAL); call eval_node_set_op1_real (en, log10_r) case default; call eval_type_error (pn, char (key), t) end select case ("sin") select case (t) case (V_REAL); call eval_node_set_op1_real (en, sin_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, sin_c) case default; call eval_type_error (pn, char (key), t) end select case ("cos") select case (t) case (V_REAL); call eval_node_set_op1_real (en, cos_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, cos_c) case default; call eval_type_error (pn, char (key), t) end select case ("tan") select case (t) case (V_REAL); call eval_node_set_op1_real (en, tan_r) case default; call eval_type_error (pn, char (key), t) end select case ("asin") select case (t) case (V_REAL); call eval_node_set_op1_real (en, asin_r) case default; call eval_type_error (pn, char (key), t) end select case ("acos") select case (t) case (V_REAL); call eval_node_set_op1_real (en, acos_r) case default; call eval_type_error (pn, char (key), t) end select case ("atan") select case (t) case (V_REAL); call eval_node_set_op1_real (en, atan_r) case default; call eval_type_error (pn, char (key), t) end select case ("sinh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, sinh_r) case default; call eval_type_error (pn, char (key), t) end select case ("cosh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, cosh_r) case default; call eval_type_error (pn, char (key), t) end select case ("tanh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, tanh_r) case default; call eval_type_error (pn, char (key), t) end select case ("asinh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, asinh_r) case default; call eval_type_error (pn, char (key), t) end select case ("acosh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, acosh_r) case default; call eval_type_error (pn, char (key), t) end select case ("atanh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, atanh_r) case default; call eval_type_error (pn, char (key), t) end select case default call parse_node_mismatch ("function name", pn_fname) end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done function" end if end subroutine eval_node_compile_unary_function @ %def eval_node_compile_unary_function @ Functions with two arguments. <>= recursive subroutine eval_node_compile_binary_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_fname, pn_arg, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en1, en2 type(string_t) :: key integer :: t1, t2 if (debug_active (D_MODEL_F)) then print *, "read binary function"; call parse_node_write (pn) end if pn_fname => parse_node_get_sub_ptr (pn) pn_arg => parse_node_get_next_ptr (pn_fname, tag="function_arg2") pn_arg1 => parse_node_get_sub_ptr (pn_arg, tag="expr") pn_arg2 => parse_node_get_next_ptr (pn_arg1, tag="expr") call eval_node_compile_expr (en1, pn_arg1, var_list) call eval_node_compile_expr (en2, pn_arg2, var_list) t1 = en1%result_type t2 = en2%result_type allocate (en) key = parse_node_get_key (pn_fname) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then select case (char (key)) case ("max") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, max_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, max_ir (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, max_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, max_rr (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t1) end select case ("min") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, min_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, min_ir (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, min_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, min_rr (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t1) end select case ("mod") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, mod_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, mod_ir (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, mod_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, mod_rr (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t1) end select case ("modulo") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, modulo_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, modulo_ir (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, modulo_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, modulo_rr (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case default call parse_node_mismatch ("function name", pn_fname) end select call eval_node_final_rec (en1) deallocate (en1) else call eval_node_init_branch (en, key, t1, en1, en2) select case (char (key)) case ("max") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, max_ii) case (V_REAL); call eval_node_set_op2_real (en, max_ir) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, max_ri) case (V_REAL); call eval_node_set_op2_real (en, max_rr) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case ("min") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, min_ii) case (V_REAL); call eval_node_set_op2_real (en, min_ir) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, min_ri) case (V_REAL); call eval_node_set_op2_real (en, min_rr) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case ("mod") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, mod_ii) case (V_REAL); call eval_node_set_op2_real (en, mod_ir) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, mod_ri) case (V_REAL); call eval_node_set_op2_real (en, mod_rr) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case ("modulo") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, modulo_ii) case (V_REAL); call eval_node_set_op2_real (en, modulo_ir) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, modulo_ri) case (V_REAL); call eval_node_set_op2_real (en, modulo_rr) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case default call parse_node_mismatch ("function name", pn_fname) end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done function" end if end subroutine eval_node_compile_binary_function @ %def eval_node_compile_binary_function @ \subsubsection{Variable definition} A block expression contains a variable definition (first argument) and an expression where the definition can be used (second argument). The [[result_type]] decides which type of expression is expected for the second argument. For numeric variables, if there is a mismatch between real and integer type, insert an extra node for type conversion. <>= recursive subroutine eval_node_compile_block_expr & (en, pn, var_list, result_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: result_type type(parse_node_t), pointer :: pn_var_spec, pn_var_subspec type(parse_node_t), pointer :: pn_var_type, pn_var_name, pn_var_expr type(parse_node_t), pointer :: pn_expr type(string_t) :: var_name type(eval_node_t), pointer :: en1, en2 integer :: var_type logical :: new if (debug_active (D_MODEL_F)) then print *, "read block expr"; call parse_node_write (pn) end if new = .false. pn_var_spec => parse_node_get_sub_ptr (pn, 2) select case (char (parse_node_get_rule_key (pn_var_spec))) case ("var_num"); var_type = V_NONE pn_var_name => parse_node_get_sub_ptr (pn_var_spec) case ("var_int"); var_type = V_INT new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_real"); var_type = V_REAL new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_cmplx"); var_type = V_CMPLX new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_logical_new"); var_type = V_LOG new = .true. pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2) pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2) case ("var_logical_spec"); var_type = V_LOG pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_plist_new"); var_type = V_SEV new = .true. pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2) pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2) case ("var_plist_spec"); var_type = V_SEV new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_alias"); var_type = V_PDG new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_string_new"); var_type = V_STR new = .true. pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2) pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2) case ("var_string_spec"); var_type = V_STR pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case default call parse_node_mismatch & ("logical|int|real|plist|alias", pn_var_type) end select pn_var_expr => parse_node_get_next_ptr (pn_var_name, 2) pn_expr => parse_node_get_next_ptr (pn_var_spec, 2) var_name = parse_node_get_string (pn_var_name) select case (var_type) case (V_LOG); var_name = "?" // var_name case (V_SEV); var_name = "@" // var_name case (V_STR); var_name = "$" // var_name ! $ sign end select call var_list_check_user_var (var_list, var_name, var_type, new) call eval_node_compile_genexpr (en1, pn_var_expr, var_list, var_type) call insert_conversion_node (en1, var_type) allocate (en) call eval_node_init_block (en, var_name, var_type, en1, var_list) call eval_node_compile_genexpr (en2, pn_expr, en%var_list, result_type) call eval_node_set_expr (en, en2) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done block expr" end if end subroutine eval_node_compile_block_expr @ %def eval_node_compile_block_expr @ Insert a conversion node for integer/real/complex transformation if necessary. What shall we do for the complex to integer/real conversion? <>= subroutine insert_conversion_node (en, result_type) type(eval_node_t), pointer :: en integer, intent(in) :: result_type type(eval_node_t), pointer :: en_conv select case (en%result_type) case (V_INT) select case (result_type) case (V_REAL) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("real"), V_REAL, en) call eval_node_set_op1_real (en_conv, real_i) en => en_conv case (V_CMPLX) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("complex"), V_CMPLX, en) call eval_node_set_op1_cmplx (en_conv, cmplx_i) en => en_conv end select case (V_REAL) select case (result_type) case (V_INT) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("int"), V_INT, en) call eval_node_set_op1_int (en_conv, int_r) en => en_conv case (V_CMPLX) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("complex"), V_CMPLX, en) call eval_node_set_op1_cmplx (en_conv, cmplx_r) en => en_conv end select case (V_CMPLX) select case (result_type) case (V_INT) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("int"), V_INT, en) call eval_node_set_op1_int (en_conv, int_c) en => en_conv case (V_REAL) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("real"), V_REAL, en) call eval_node_set_op1_real (en_conv, real_c) en => en_conv end select case default end select end subroutine insert_conversion_node @ %def insert_conversion_node @ \subsubsection{Conditionals} A conditional has the structure if lexpr then expr else expr. So we first evaluate the logical expression, then depending on the result the first or second expression. Note that the second expression is mandatory. The [[result_type]], if present, defines the requested type of the [[then]] and [[else]] clauses. Default is numeric (int/real). If there is a mismatch between real and integer result types, insert conversion nodes. <>= recursive subroutine eval_node_compile_conditional & (en, pn, var_list, result_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: result_type type(parse_node_t), pointer :: pn_condition, pn_expr type(parse_node_t), pointer :: pn_maybe_elsif, pn_elsif_branch type(parse_node_t), pointer :: pn_maybe_else, pn_else_branch, pn_else_expr type(eval_node_t), pointer :: en0, en1, en2 integer :: restype if (debug_active (D_MODEL_F)) then print *, "read conditional"; call parse_node_write (pn) end if pn_condition => parse_node_get_sub_ptr (pn, 2, tag="lexpr") pn_expr => parse_node_get_next_ptr (pn_condition, 2) call eval_node_compile_lexpr (en0, pn_condition, var_list) call eval_node_compile_genexpr (en1, pn_expr, var_list, result_type) if (present (result_type)) then restype = major_result_type (result_type, en1%result_type) else restype = en1%result_type end if pn_maybe_elsif => parse_node_get_next_ptr (pn_expr) select case (char (parse_node_get_rule_key (pn_maybe_elsif))) case ("maybe_elsif_expr", & "maybe_elsif_lexpr", & "maybe_elsif_pexpr", & "maybe_elsif_cexpr", & "maybe_elsif_sexpr") pn_elsif_branch => parse_node_get_sub_ptr (pn_maybe_elsif) pn_maybe_else => parse_node_get_next_ptr (pn_maybe_elsif) select case (char (parse_node_get_rule_key (pn_maybe_else))) case ("maybe_else_expr", & "maybe_else_lexpr", & "maybe_else_pexpr", & "maybe_else_cexpr", & "maybe_else_sexpr") pn_else_branch => parse_node_get_sub_ptr (pn_maybe_else) pn_else_expr => parse_node_get_sub_ptr (pn_else_branch, 2) case default pn_else_expr => null () end select call eval_node_compile_elsif & (en2, pn_elsif_branch, pn_else_expr, var_list, restype) case ("maybe_else_expr", & "maybe_else_lexpr", & "maybe_else_pexpr", & "maybe_else_cexpr", & "maybe_else_sexpr") pn_maybe_else => pn_maybe_elsif pn_maybe_elsif => null () pn_else_branch => parse_node_get_sub_ptr (pn_maybe_else) pn_else_expr => parse_node_get_sub_ptr (pn_else_branch, 2) call eval_node_compile_genexpr & (en2, pn_else_expr, var_list, restype) case ("endif") call eval_node_compile_default_else (en2, restype) case default call msg_bug ("Broken conditional: unexpected " & // char (parse_node_get_rule_key (pn_maybe_elsif))) end select call eval_node_create_conditional (en, en0, en1, en2, restype) call conditional_insert_conversion_nodes (en, restype) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done conditional" end if end subroutine eval_node_compile_conditional @ %def eval_node_compile_conditional @ This recursively generates 'elsif' conditionals as a chain of sub-nodes of the main conditional. <>= recursive subroutine eval_node_compile_elsif & (en, pn, pn_else_expr, var_list, result_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(parse_node_t), pointer :: pn_else_expr type(var_list_t), intent(in), target :: var_list integer, intent(inout) :: result_type type(parse_node_t), pointer :: pn_next, pn_condition, pn_expr type(eval_node_t), pointer :: en0, en1, en2 pn_condition => parse_node_get_sub_ptr (pn, 2, tag="lexpr") pn_expr => parse_node_get_next_ptr (pn_condition, 2) call eval_node_compile_lexpr (en0, pn_condition, var_list) call eval_node_compile_genexpr (en1, pn_expr, var_list, result_type) result_type = major_result_type (result_type, en1%result_type) pn_next => parse_node_get_next_ptr (pn) if (associated (pn_next)) then call eval_node_compile_elsif & (en2, pn_next, pn_else_expr, var_list, result_type) result_type = major_result_type (result_type, en2%result_type) else if (associated (pn_else_expr)) then call eval_node_compile_genexpr & (en2, pn_else_expr, var_list, result_type) result_type = major_result_type (result_type, en2%result_type) else call eval_node_compile_default_else (en2, result_type) end if call eval_node_create_conditional (en, en0, en1, en2, result_type) end subroutine eval_node_compile_elsif @ %def eval_node_compile_elsif @ This makes a default 'else' branch in case it was omitted. The default value just depends on the expected type. <>= subroutine eval_node_compile_default_else (en, result_type) type(eval_node_t), pointer :: en integer, intent(in) :: result_type type(subevt_t) :: pval_empty type(pdg_array_t) :: aval_undefined allocate (en) select case (result_type) case (V_LOG); call eval_node_init_log (en, .false.) case (V_INT); call eval_node_init_int (en, 0) case (V_REAL); call eval_node_init_real (en, 0._default) case (V_CMPLX) call eval_node_init_cmplx (en, (0._default, 0._default)) case (V_SEV) call subevt_init (pval_empty) call eval_node_init_subevt (en, pval_empty) case (V_PDG) call eval_node_init_pdg_array (en, aval_undefined) case (V_STR) call eval_node_init_string (en, var_str ("")) case default call msg_bug ("Undefined type for 'else' branch in conditional") end select end subroutine eval_node_compile_default_else @ %def eval_node_compile_default_else @ If the logical expression is constant, we can simplify the conditional node by replacing it with the selected branch. Otherwise, we initialize a true branching. <>= subroutine eval_node_create_conditional (en, en0, en1, en2, result_type) type(eval_node_t), pointer :: en, en0, en1, en2 integer, intent(in) :: result_type if (en0%type == EN_CONSTANT) then if (en0%lval) then en => en1 call eval_node_final_rec (en2) deallocate (en2) else en => en2 call eval_node_final_rec (en1) deallocate (en1) end if else allocate (en) call eval_node_init_conditional (en, result_type, en0, en1, en2) end if end subroutine eval_node_create_conditional @ %def eval_node_create_conditional @ Return the numerical result type which should be used for the combination of the two result types. <>= function major_result_type (t1, t2) result (t) integer :: t integer, intent(in) :: t1, t2 select case (t1) case (V_INT) select case (t2) case (V_INT, V_REAL, V_CMPLX) t = t2 case default call type_mismatch () end select case (V_REAL) select case (t2) case (V_INT) t = t1 case (V_REAL, V_CMPLX) t = t2 case default call type_mismatch () end select case (V_CMPLX) select case (t2) case (V_INT, V_REAL, V_CMPLX) t = t1 case default call type_mismatch () end select case default if (t1 == t2) then t = t1 else call type_mismatch () end if end select contains subroutine type_mismatch () call msg_bug ("Type mismatch in branches of a conditional expression") end subroutine type_mismatch end function major_result_type @ %def major_result_type @ Recursively insert conversion nodes where necessary. <>= recursive subroutine conditional_insert_conversion_nodes (en, result_type) type(eval_node_t), intent(inout), target :: en integer, intent(in) :: result_type select case (result_type) case (V_INT, V_REAL, V_CMPLX) call insert_conversion_node (en%arg1, result_type) if (en%arg2%type == EN_CONDITIONAL) then call conditional_insert_conversion_nodes (en%arg2, result_type) else call insert_conversion_node (en%arg2, result_type) end if end select end subroutine conditional_insert_conversion_nodes @ %def conditional_insert_conversion_nodes @ \subsubsection{Logical expressions} A logical expression consists of one or more singlet logical expressions concatenated by [[;]]. This is for allowing side-effects, only the last value is used. <>= recursive subroutine eval_node_compile_lexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_term, pn_sequel, pn_arg type(eval_node_t), pointer :: en1, en2 if (debug_active (D_MODEL_F)) then print *, "read lexpr"; call parse_node_write (pn) end if pn_term => parse_node_get_sub_ptr (pn, tag="lsinglet") call eval_node_compile_lsinglet (en, pn_term, var_list) pn_sequel => parse_node_get_next_ptr (pn_term, tag="lsequel") do while (associated (pn_sequel)) pn_arg => parse_node_get_sub_ptr (pn_sequel, 2, tag="lsinglet") en1 => en call eval_node_compile_lsinglet (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call eval_node_init_log (en, ignore_first_ll (en1, en2)) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("lsequel"), V_LOG, en1, en2) call eval_node_set_op2_log (en, ignore_first_ll) end if pn_sequel => parse_node_get_next_ptr (pn_sequel) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done lexpr" end if end subroutine eval_node_compile_lexpr @ %def eval_node_compile_lexpr @ A logical singlet expression consists of one or more logical terms concatenated by [[or]]. <>= recursive subroutine eval_node_compile_lsinglet (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_term, pn_alternative, pn_arg type(eval_node_t), pointer :: en1, en2 if (debug_active (D_MODEL_F)) then print *, "read lsinglet"; call parse_node_write (pn) end if pn_term => parse_node_get_sub_ptr (pn, tag="lterm") call eval_node_compile_lterm (en, pn_term, var_list) pn_alternative => parse_node_get_next_ptr (pn_term, tag="alternative") do while (associated (pn_alternative)) pn_arg => parse_node_get_sub_ptr (pn_alternative, 2, tag="lterm") en1 => en call eval_node_compile_lterm (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call eval_node_init_log (en, or_ll (en1, en2)) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("alternative"), V_LOG, en1, en2) call eval_node_set_op2_log (en, or_ll) end if pn_alternative => parse_node_get_next_ptr (pn_alternative) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done lsinglet" end if end subroutine eval_node_compile_lsinglet @ %def eval_node_compile_lsinglet @ A logical term consists of one or more logical values concatenated by [[and]]. <>= recursive subroutine eval_node_compile_lterm (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_term, pn_coincidence, pn_arg type(eval_node_t), pointer :: en1, en2 if (debug_active (D_MODEL_F)) then print *, "read lterm"; call parse_node_write (pn) end if pn_term => parse_node_get_sub_ptr (pn) call eval_node_compile_lvalue (en, pn_term, var_list) pn_coincidence => parse_node_get_next_ptr (pn_term, tag="coincidence") do while (associated (pn_coincidence)) pn_arg => parse_node_get_sub_ptr (pn_coincidence, 2) en1 => en call eval_node_compile_lvalue (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call eval_node_init_log (en, and_ll (en1, en2)) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("coincidence"), V_LOG, en1, en2) call eval_node_set_op2_log (en, and_ll) end if pn_coincidence => parse_node_get_next_ptr (pn_coincidence) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done lterm" end if end subroutine eval_node_compile_lterm @ %def eval_node_compile_lterm @ Logical variables are disabled, because they are confused with the l.h.s.\ of compared expressions. <>= recursive subroutine eval_node_compile_lvalue (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list if (debug_active (D_MODEL_F)) then print *, "read lvalue"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("true") allocate (en) call eval_node_init_log (en, .true.) case ("false") allocate (en) call eval_node_init_log (en, .false.) case ("negation") call eval_node_compile_negation (en, pn, var_list) case ("lvariable") call eval_node_compile_variable (en, pn, var_list, V_LOG) case ("lexpr") call eval_node_compile_lexpr (en, pn, var_list) case ("block_lexpr") call eval_node_compile_block_expr (en, pn, var_list, V_LOG) case ("conditional_lexpr") call eval_node_compile_conditional (en, pn, var_list, V_LOG) case ("compared_expr") call eval_node_compile_compared_expr (en, pn, var_list, V_REAL) case ("compared_sexpr") call eval_node_compile_compared_expr (en, pn, var_list, V_STR) case ("all_fun", "any_fun", "no_fun", "photon_isolation_fun") call eval_node_compile_log_function (en, pn, var_list) case ("record_cmd") call eval_node_compile_record_cmd (en, pn, var_list) case default call parse_node_mismatch & ("true|false|negation|lvariable|" // & "lexpr|block_lexpr|conditional_lexpr|" // & "compared_expr|compared_sexpr|logical_pexpr", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done lvalue" end if end subroutine eval_node_compile_lvalue @ %def eval_node_compile_lvalue @ A negation consists of the keyword [[not]] and a logical value. <>= recursive subroutine eval_node_compile_negation (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_arg type(eval_node_t), pointer :: en1 if (debug_active (D_MODEL_F)) then print *, "read negation"; call parse_node_write (pn) end if pn_arg => parse_node_get_sub_ptr (pn, 2) call eval_node_compile_lvalue (en1, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT) then call eval_node_init_log (en, not_l (en1)) call eval_node_final_rec (en1) deallocate (en1) else call eval_node_init_branch (en, var_str ("not"), V_LOG, en1) call eval_node_set_op1_log (en, not_l) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done negation" end if end subroutine eval_node_compile_negation @ %def eval_node_compile_negation @ \subsubsection{Comparisons} Up to the loop, this is easy. There is always at least one comparison. This is evaluated, and the result is the logical node [[en]]. If it is constant, we keep its second sub-node as [[en2]]. (Thus, at the very end [[en2]] has to be deleted if [[en]] is (still) constant.) If there is another comparison, we first check if the first comparison was constant. In that case, there are two possibilities: (i) it was true. Then, its right-hand side is compared with the new right-hand side, and the result replaces the previous one which is deleted. (ii) it was false. In this case, the result of the whole comparison is false, and we can exit the loop without evaluating anything else. Now assume that the first comparison results in a valid branch, its second sub-node kept as [[en2]]. We first need a copy of this, which becomes the new left-hand side. If [[en2]] is constant, we make an identical constant node [[en1]]. Otherwise, we make [[en1]] an appropriate pointer node. Next, the first branch is saved as [[en0]] and we evaluate the comparison between [[en1]] and the a right-hand side. If this turns out to be constant, there are again two possibilities: (i) true, then we revert to the previous result. (ii) false, then the wh <>= recursive subroutine eval_node_compile_compared_expr (en, pn, var_list, type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in) :: type type(parse_node_t), pointer :: pn_comparison, pn_expr1 type(eval_node_t), pointer :: en0, en1, en2 if (debug_active (D_MODEL_F)) then print *, "read comparison"; call parse_node_write (pn) end if select case (type) case (V_INT, V_REAL) pn_expr1 => parse_node_get_sub_ptr (pn, tag="expr") call eval_node_compile_expr (en1, pn_expr1, var_list) pn_comparison => parse_node_get_next_ptr (pn_expr1, tag="comparison") case (V_STR) pn_expr1 => parse_node_get_sub_ptr (pn, tag="sexpr") call eval_node_compile_sexpr (en1, pn_expr1, var_list) pn_comparison => parse_node_get_next_ptr (pn_expr1, tag="str_comparison") end select call eval_node_compile_comparison & (en, en1, en2, pn_comparison, var_list, type) pn_comparison => parse_node_get_next_ptr (pn_comparison) SCAN_FURTHER: do while (associated (pn_comparison)) if (en%type == EN_CONSTANT) then if (en%lval) then en1 => en2 call eval_node_final_rec (en); deallocate (en) call eval_node_compile_comparison & (en, en1, en2, pn_comparison, var_list, type) else exit SCAN_FURTHER end if else allocate (en1) if (en2%type == EN_CONSTANT) then select case (en2%result_type) case (V_INT); call eval_node_init_int (en1, en2%ival) case (V_REAL); call eval_node_init_real (en1, en2%rval) case (V_STR); call eval_node_init_string (en1, en2%sval) end select else select case (en2%result_type) case (V_INT); call eval_node_init_int_ptr & (en1, var_str ("(previous)"), en2%ival, en2%value_is_known) case (V_REAL); call eval_node_init_real_ptr & (en1, var_str ("(previous)"), en2%rval, en2%value_is_known) case (V_STR); call eval_node_init_string_ptr & (en1, var_str ("(previous)"), en2%sval, en2%value_is_known) end select end if en0 => en call eval_node_compile_comparison & (en, en1, en2, pn_comparison, var_list, type) if (en%type == EN_CONSTANT) then if (en%lval) then call eval_node_final_rec (en); deallocate (en) en => en0 else call eval_node_final_rec (en0); deallocate (en0) exit SCAN_FURTHER end if else en1 => en allocate (en) call eval_node_init_branch (en, var_str ("and"), V_LOG, en0, en1) call eval_node_set_op2_log (en, and_ll) end if end if pn_comparison => parse_node_get_next_ptr (pn_comparison) end do SCAN_FURTHER if (en%type == EN_CONSTANT .and. associated (en2)) then call eval_node_final_rec (en2); deallocate (en2) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done compared_expr" end if end subroutine eval_node_compile_compared_expr @ %dev eval_node_compile_compared_expr @ This takes two extra arguments: [[en1]], the left-hand-side of the comparison, is already allocated and evaluated. [[en2]] (the right-hand side) and [[en]] (the result) are allocated by the routine. [[pn]] is the parse node which contains the operator and the right-hand side as subnodes. If the result of the comparison is constant, [[en1]] is deleted but [[en2]] is kept, because it may be used in a subsequent comparison. [[en]] then becomes a constant. If the result is variable, [[en]] becomes a branch node which refers to [[en1]] and [[en2]]. <>= recursive subroutine eval_node_compile_comparison & (en, en1, en2, pn, var_list, type) type(eval_node_t), pointer :: en, en1, en2 type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in) :: type type(parse_node_t), pointer :: pn_op, pn_arg type(string_t) :: key integer :: t1, t2 real(default), pointer :: tolerance_ptr pn_op => parse_node_get_sub_ptr (pn) key = parse_node_get_key (pn_op) select case (type) case (V_INT, V_REAL) pn_arg => parse_node_get_next_ptr (pn_op, tag="expr") call eval_node_compile_expr (en2, pn_arg, var_list) case (V_STR) pn_arg => parse_node_get_next_ptr (pn_op, tag="sexpr") call eval_node_compile_sexpr (en2, pn_arg, var_list) end select t1 = en1%result_type t2 = en2%result_type allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call var_list%get_rptr (var_str ("tolerance"), tolerance_ptr) en1%tolerance => tolerance_ptr select case (char (key)) case ("<") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_lt_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ll_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ll_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ll_rr (en1, en2)) end select end select case (">") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_gt_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_gg_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_gg_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_gg_rr (en1, en2)) end select end select case ("<=") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_le_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ls_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ls_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ls_rr (en1, en2)) end select end select case (">=") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ge_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_gs_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_gs_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_gs_rr (en1, en2)) end select end select case ("==") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_eq_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_se_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_se_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_se_rr (en1, en2)) end select case (V_STR) select case (t2) case (V_STR); call eval_node_init_log (en, comp_eq_ss (en1, en2)) end select end select case ("<>") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ne_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ns_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ns_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ns_rr (en1, en2)) end select case (V_STR) select case (t2) case (V_STR); call eval_node_init_log (en, comp_ne_ss (en1, en2)) end select end select end select call eval_node_final_rec (en1) deallocate (en1) else call eval_node_init_branch (en, key, V_LOG, en1, en2) select case (char (key)) case ("<") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_lt_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_ll_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ll_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_ll_rr) end select end select case (">") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_gt_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_gg_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_gg_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_gg_rr) end select end select case ("<=") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_le_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_ls_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ls_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_ls_rr) end select end select case (">=") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ge_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_gs_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_gs_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_gs_rr) end select end select case ("==") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_eq_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_se_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_se_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_se_rr) end select case (V_STR) select case (t2) case (V_STR); call eval_node_set_op2_log (en, comp_eq_ss) end select end select case ("<>") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ne_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_ns_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ns_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_ns_rr) end select case (V_STR) select case (t2) case (V_STR); call eval_node_set_op2_log (en, comp_ne_ss) end select end select end select call var_list%get_rptr (var_str ("tolerance"), tolerance_ptr) en1%tolerance => tolerance_ptr end if end subroutine eval_node_compile_comparison @ %def eval_node_compile_comparison @ \subsubsection{Recording analysis data} The [[record]] command is actually a logical expression which always evaluates [[true]]. <>= recursive subroutine eval_node_compile_record_cmd (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_key, pn_tag, pn_arg type(parse_node_t), pointer :: pn_arg1, pn_arg2, pn_arg3, pn_arg4 type(eval_node_t), pointer :: en0, en1, en2, en3, en4 real(default), pointer :: event_weight if (debug_active (D_MODEL_F)) then print *, "read record_cmd"; call parse_node_write (pn) end if pn_key => parse_node_get_sub_ptr (pn) pn_tag => parse_node_get_next_ptr (pn_key) pn_arg => parse_node_get_next_ptr (pn_tag) select case (char (parse_node_get_key (pn_key))) case ("record") call var_list%get_rptr (var_str ("event_weight"), event_weight) case ("record_unweighted") event_weight => null () case ("record_excess") call var_list%get_rptr (var_str ("event_excess"), event_weight) end select select case (char (parse_node_get_rule_key (pn_tag))) case ("analysis_id") allocate (en0) call eval_node_init_string (en0, parse_node_get_string (pn_tag)) case default call eval_node_compile_sexpr (en0, pn_tag, var_list) end select allocate (en) if (associated (pn_arg)) then pn_arg1 => parse_node_get_sub_ptr (pn_arg) call eval_node_compile_expr (en1, pn_arg1, var_list) if (en1%result_type == V_INT) & call insert_conversion_node (en1, V_REAL) pn_arg2 => parse_node_get_next_ptr (pn_arg1) if (associated (pn_arg2)) then call eval_node_compile_expr (en2, pn_arg2, var_list) if (en2%result_type == V_INT) & call insert_conversion_node (en2, V_REAL) pn_arg3 => parse_node_get_next_ptr (pn_arg2) if (associated (pn_arg3)) then call eval_node_compile_expr (en3, pn_arg3, var_list) if (en3%result_type == V_INT) & call insert_conversion_node (en3, V_REAL) pn_arg4 => parse_node_get_next_ptr (pn_arg3) if (associated (pn_arg4)) then call eval_node_compile_expr (en4, pn_arg4, var_list) if (en4%result_type == V_INT) & call insert_conversion_node (en4, V_REAL) call eval_node_init_record_cmd & (en, event_weight, en0, en1, en2, en3, en4) else call eval_node_init_record_cmd & (en, event_weight, en0, en1, en2, en3) end if else call eval_node_init_record_cmd (en, event_weight, en0, en1, en2) end if else call eval_node_init_record_cmd (en, event_weight, en0, en1) end if else call eval_node_init_record_cmd (en, event_weight, en0) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done record_cmd" end if end subroutine eval_node_compile_record_cmd @ %def eval_node_compile_record_cmd @ \subsubsection{Particle-list expressions} A particle expression is a subevent or a concatenation of particle-list terms (using \verb|join|). <>= recursive subroutine eval_node_compile_pexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_pterm, pn_concatenation, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(subevt_t) :: subevt if (debug_active (D_MODEL_F)) then print *, "read pexpr"; call parse_node_write (pn) end if pn_pterm => parse_node_get_sub_ptr (pn) call eval_node_compile_pterm (en, pn_pterm, var_list) pn_concatenation => & parse_node_get_next_ptr (pn_pterm, tag="pconcatenation") do while (associated (pn_concatenation)) pn_op => parse_node_get_sub_ptr (pn_concatenation) pn_arg => parse_node_get_next_ptr (pn_op) en1 => en call eval_node_compile_pterm (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call subevt_join (subevt, en1%pval, en2%pval) call eval_node_init_subevt (en, subevt) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("join"), V_SEV, en1, en2) call eval_node_set_op2_sev (en, join_pp) end if pn_concatenation => parse_node_get_next_ptr (pn_concatenation) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done pexpr" end if end subroutine eval_node_compile_pexpr @ %def eval_node_compile_pexpr @ A particle term is a subevent or a combination of particle-list values (using \verb|combine|). <>= recursive subroutine eval_node_compile_pterm (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_pvalue, pn_combination, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(subevt_t) :: subevt if (debug_active (D_MODEL_F)) then print *, "read pterm"; call parse_node_write (pn) end if pn_pvalue => parse_node_get_sub_ptr (pn) call eval_node_compile_pvalue (en, pn_pvalue, var_list) pn_combination => & parse_node_get_next_ptr (pn_pvalue, tag="pcombination") do while (associated (pn_combination)) pn_op => parse_node_get_sub_ptr (pn_combination) pn_arg => parse_node_get_next_ptr (pn_op) en1 => en call eval_node_compile_pvalue (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call subevt_combine (subevt, en1%pval, en2%pval) call eval_node_init_subevt (en, subevt) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("combine"), V_SEV, en1, en2) call eval_node_set_op2_sev (en, combine_pp) end if pn_combination => parse_node_get_next_ptr (pn_combination) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done pterm" end if end subroutine eval_node_compile_pterm @ %def eval_node_compile_pterm @ A particle-list value is a PDG-code array, a particle identifier, a variable, a (grouped) pexpr, a block pexpr, a conditional, or a particle-list function. The [[cexpr]] node is responsible for transforming a constant PDG-code array into a subevent. It takes the code array as its first argument, the event subevent as its second argument, and the requested particle type (incoming/outgoing) as its zero-th argument. The result is the list of particles in the event that match the code array. <>= recursive subroutine eval_node_compile_pvalue (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_prefix_cexpr type(eval_node_t), pointer :: en1, en2, en0 type(string_t) :: key type(subevt_t), pointer :: evt_ptr logical, pointer :: known if (debug_active (D_MODEL_F)) then print *, "read pvalue"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("pexpr_src") call eval_node_compile_prefix_cexpr (en1, pn, var_list) allocate (en2) if (var_list%contains (var_str ("@evt"))) then call var_list%get_pptr (var_str ("@evt"), evt_ptr, known) call eval_node_init_subevt_ptr (en2, var_str ("@evt"), evt_ptr, known) allocate (en) call eval_node_init_branch & (en, var_str ("prt_selection"), V_SEV, en1, en2) call eval_node_set_op2_sev (en, select_pdg_ca) allocate (en0) pn_prefix_cexpr => parse_node_get_sub_ptr (pn) key = parse_node_get_rule_key (pn_prefix_cexpr) select case (char (key)) case ("beam_prt") call eval_node_init_int (en0, PRT_BEAM) en%arg0 => en0 case ("incoming_prt") call eval_node_init_int (en0, PRT_INCOMING) en%arg0 => en0 case ("outgoing_prt") call eval_node_init_int (en0, PRT_OUTGOING) en%arg0 => en0 case ("unspecified_prt") call eval_node_init_int (en0, PRT_OUTGOING) en%arg0 => en0 end select else call parse_node_write (pn) call msg_bug (" Missing event data while compiling pvalue") end if case ("pvariable") call eval_node_compile_variable (en, pn, var_list, V_SEV) case ("pexpr") call eval_node_compile_pexpr (en, pn, var_list) case ("block_pexpr") call eval_node_compile_block_expr (en, pn, var_list, V_SEV) case ("conditional_pexpr") call eval_node_compile_conditional (en, pn, var_list, V_SEV) case ("join_fun", "combine_fun", "collect_fun", "cluster_fun", & "select_fun", "extract_fun", "sort_fun", "select_b_jet_fun", & "select_non_bjet_fun", "select_c_jet_fun", & "select_light_jet_fun") call eval_node_compile_prt_function (en, pn, var_list) case default call parse_node_mismatch & ("prefix_cexpr|pvariable|" // & "grouped_pexpr|block_pexpr|conditional_pexpr|" // & "prt_function", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done pvalue" end if end subroutine eval_node_compile_pvalue @ %def eval_node_compile_pvalue @ \subsubsection{Particle functions} This combines the treatment of 'join', 'combine', 'collect', 'cluster', 'select', and 'extract' which all have the same syntax. The one or two argument nodes are allocated. If there is a condition, the condition node is also allocated as a logical expression, for which the variable list is augmented by the appropriate (unary/binary) observables. <>= recursive subroutine eval_node_compile_prt_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_clause, pn_key, pn_cond, pn_args type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1, en2 type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read prt_function"; call parse_node_write (pn) end if pn_clause => parse_node_get_sub_ptr (pn) pn_key => parse_node_get_sub_ptr (pn_clause) pn_cond => parse_node_get_next_ptr (pn_key) if (associated (pn_cond)) & pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2) pn_args => parse_node_get_next_ptr (pn_clause) pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) allocate (en) if (.not. associated (pn_arg2)) then select case (char (key)) case ("collect") call eval_node_init_prt_fun_unary (en, en1, key, collect_p) case ("cluster") if (fastjet_available ()) then call fastjet_init () else call msg_fatal & ("'cluster' function requires FastJet, which is not enabled") end if en1%var_list => var_list call eval_node_init_prt_fun_unary (en, en1, key, cluster_p) call var_list%get_iptr (var_str ("jet_algorithm"), en1%jet_algorithm) call var_list%get_rptr (var_str ("jet_r"), en1%jet_r) call var_list%get_rptr (var_str ("jet_p"), en1%jet_p) call var_list%get_rptr (var_str ("jet_ycut"), en1%jet_ycut) call var_list%get_rptr (var_str ("jet_dcut"), en1%jet_dcut) case ("select") call eval_node_init_prt_fun_unary (en, en1, key, select_p) case ("extract") call eval_node_init_prt_fun_unary (en, en1, key, extract_p) case ("sort") call eval_node_init_prt_fun_unary (en, en1, key, sort_p) case ("select_b_jet") call eval_node_init_prt_fun_unary (en, en1, key, select_b_jet_p) case ("select_non_b_jet") call eval_node_init_prt_fun_unary (en, en1, key, select_non_b_jet_p) case ("select_c_jet") call eval_node_init_prt_fun_unary (en, en1, key, select_c_jet_p) case ("select_light_jet") call eval_node_init_prt_fun_unary (en, en1, key, select_light_jet_p) case default call msg_bug (" Unary particle function '" // char (key) // & "' undefined") end select else call eval_node_compile_pexpr (en2, pn_arg2, var_list) select case (char (key)) case ("join") call eval_node_init_prt_fun_binary (en, en1, en2, key, join_pp) case ("combine") call eval_node_init_prt_fun_binary (en, en1, en2, key, combine_pp) case ("collect") call eval_node_init_prt_fun_binary (en, en1, en2, key, collect_pp) case ("select") call eval_node_init_prt_fun_binary (en, en1, en2, key, select_pp) case ("sort") call eval_node_init_prt_fun_binary (en, en1, en2, key, sort_pp) case default call msg_bug (" Binary particle function '" // char (key) // & "' undefined") end select end if if (associated (pn_cond)) then call eval_node_set_observables (en, var_list) select case (char (key)) case ("extract", "sort") call eval_node_compile_expr (en0, pn_arg0, en%var_list) case default call eval_node_compile_lexpr (en0, pn_arg0, en%var_list) end select en%arg0 => en0 end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done prt_function" end if end subroutine eval_node_compile_prt_function @ %def eval_node_compile_prt_function @ The [[eval]] expression is similar, but here the expression [[arg0]] is mandatory, and the whole thing evaluates to a numeric value. <>= recursive subroutine eval_node_compile_eval_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_key, pn_arg0, pn_args, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1, en2 type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read eval_function"; call parse_node_write (pn) end if pn_key => parse_node_get_sub_ptr (pn) pn_arg0 => parse_node_get_next_ptr (pn_key) pn_args => parse_node_get_next_ptr (pn_arg0) pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) allocate (en) if (.not. associated (pn_arg2)) then call eval_node_init_eval_fun_unary (en, en1, key) else call eval_node_compile_pexpr (en2, pn_arg2, var_list) call eval_node_init_eval_fun_binary (en, en1, en2, key) end if call eval_node_set_observables (en, var_list) call eval_node_compile_expr (en0, pn_arg0, en%var_list) if (en0%result_type /= V_REAL) & call msg_fatal (" 'eval' function does not result in real value") call eval_node_set_expr (en, en0) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done eval_function" end if end subroutine eval_node_compile_eval_function @ %def eval_node_compile_eval_function @ Logical functions of subevents. For [[photon_isolation]] there is a conditional selection expression instead of a mandatory logical expression, so in the case of the absence of the selection we have to create a logical [[eval_node_t]] with value [[.true.]]. <>= recursive subroutine eval_node_compile_log_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_clause, pn_key, pn_str, pn_cond type(parse_node_t), pointer :: pn_arg0, pn_args, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1, en2 type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read log_function"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("all_fun", "any_fun", "no_fun") pn_key => parse_node_get_sub_ptr (pn) pn_arg0 => parse_node_get_next_ptr (pn_key) pn_args => parse_node_get_next_ptr (pn_arg0) case ("photon_isolation_fun") pn_clause => parse_node_get_sub_ptr (pn) pn_key => parse_node_get_sub_ptr (pn_clause) pn_cond => parse_node_get_next_ptr (pn_key) if (associated (pn_cond)) then pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2) else pn_arg0 => null () end if pn_args => parse_node_get_next_ptr (pn_clause) case default call parse_node_mismatch ("all_fun|any_fun|" // & "no_fun|photon_isolation_fun", pn) end select pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) allocate (en) if (.not. associated (pn_arg2)) then select case (char (key)) case ("all") call eval_node_init_log_fun_unary (en, en1, key, all_p) case ("any") call eval_node_init_log_fun_unary (en, en1, key, any_p) case ("no") call eval_node_init_log_fun_unary (en, en1, key, no_p) case default call msg_bug ("Unary logical particle function '" // char (key) // & "' undefined") end select else call eval_node_compile_pexpr (en2, pn_arg2, var_list) select case (char (key)) case ("all") call eval_node_init_log_fun_binary (en, en1, en2, key, all_pp) case ("any") call eval_node_init_log_fun_binary (en, en1, en2, key, any_pp) case ("no") call eval_node_init_log_fun_binary (en, en1, en2, key, no_pp) case ("photon_isolation") en1%var_list => var_list call var_list%get_rptr (var_str ("photon_iso_eps"), en1%photon_iso_eps) call var_list%get_rptr (var_str ("photon_iso_n"), en1%photon_iso_n) call var_list%get_rptr (var_str ("photon_iso_r0"), en1%photon_iso_r0) call eval_node_init_log_fun_binary (en, en1, en2, key, photon_isolation_pp) case default call msg_bug ("Binary logical particle function '" // char (key) // & "' undefined") end select end if if (associated (pn_arg0)) then call eval_node_set_observables (en, var_list) select case (char (key)) case ("all", "any", "no", "photon_isolation") call eval_node_compile_lexpr (en0, pn_arg0, en%var_list) case default call msg_bug ("Compiling logical particle function: missing mode") end select call eval_node_set_expr (en, en0, V_LOG) else select case (char (key)) case ("photon_isolation") allocate (en0) call eval_node_init_log (en0, .true.) call eval_node_set_expr (en, en0, V_LOG) case default call msg_bug ("Only photon isolation can be called unconditionally") end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done log_function" end if end subroutine eval_node_compile_log_function @ %def eval_node_compile_log_function @ Numeric functions of subevents. <>= recursive subroutine eval_node_compile_numeric_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_clause, pn_key, pn_cond, pn_args type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1, en2 type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read numeric_function"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("count_fun") pn_clause => parse_node_get_sub_ptr (pn) pn_key => parse_node_get_sub_ptr (pn_clause) pn_cond => parse_node_get_next_ptr (pn_key) if (associated (pn_cond)) then pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2) else pn_arg0 => null () end if pn_args => parse_node_get_next_ptr (pn_clause) end select pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) allocate (en) if (.not. associated (pn_arg2)) then select case (char (key)) case ("count") call eval_node_init_int_fun_unary (en, en1, key, count_a) case default call msg_bug ("Unary subevent function '" // char (key) // & "' undefined") end select else call eval_node_compile_pexpr (en2, pn_arg2, var_list) select case (char (key)) case ("count") call eval_node_init_int_fun_binary (en, en1, en2, key, count_pp) case default call msg_bug ("Binary subevent function '" // char (key) // & "' undefined") end select end if if (associated (pn_arg0)) then call eval_node_set_observables (en, var_list) select case (char (key)) case ("count") call eval_node_compile_lexpr (en0, pn_arg0, en%var_list) call eval_node_set_expr (en, en0, V_INT) end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done numeric_function" end if end subroutine eval_node_compile_numeric_function @ %def eval_node_compile_numeric_function @ \subsubsection{PDG-code arrays} A PDG-code expression is (optionally) prefixed by [[beam]], [[incoming]], or [[outgoing]], a block, or a conditional. In any case, it evaluates to a constant. <>= recursive subroutine eval_node_compile_prefix_cexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_avalue, pn_prt type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read prefix_cexpr"; call parse_node_write (pn) end if pn_avalue => parse_node_get_sub_ptr (pn) key = parse_node_get_rule_key (pn_avalue) select case (char (key)) case ("beam_prt") pn_prt => parse_node_get_sub_ptr (pn_avalue, 2) call eval_node_compile_cexpr (en, pn_prt, var_list) case ("incoming_prt") pn_prt => parse_node_get_sub_ptr (pn_avalue, 2) call eval_node_compile_cexpr (en, pn_prt, var_list) case ("outgoing_prt") pn_prt => parse_node_get_sub_ptr (pn_avalue, 2) call eval_node_compile_cexpr (en, pn_prt, var_list) case ("unspecified_prt") pn_prt => parse_node_get_sub_ptr (pn_avalue, 1) call eval_node_compile_cexpr (en, pn_prt, var_list) case default call parse_node_mismatch & ("beam_prt|incoming_prt|outgoing_prt|unspecified_prt", & pn_avalue) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done prefix_cexpr" end if end subroutine eval_node_compile_prefix_cexpr @ %def eval_node_compile_prefix_cexpr @ A PDG array is a string of PDG code definitions (or aliases), concatenated by ':'. The code definitions may be variables which are not defined at compile time, so we have to allocate sub-nodes. This analogous to [[eval_node_compile_term]]. <>= recursive subroutine eval_node_compile_cexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_prt, pn_concatenation type(eval_node_t), pointer :: en1, en2 type(pdg_array_t) :: aval if (debug_active (D_MODEL_F)) then print *, "read cexpr"; call parse_node_write (pn) end if pn_prt => parse_node_get_sub_ptr (pn) call eval_node_compile_avalue (en, pn_prt, var_list) pn_concatenation => parse_node_get_next_ptr (pn_prt) do while (associated (pn_concatenation)) pn_prt => parse_node_get_sub_ptr (pn_concatenation, 2) en1 => en call eval_node_compile_avalue (en2, pn_prt, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call concat_cc (aval, en1, en2) call eval_node_init_pdg_array (en, aval) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch (en, var_str (":"), V_PDG, en1, en2) call eval_node_set_op2_pdg (en, concat_cc) end if pn_concatenation => parse_node_get_next_ptr (pn_concatenation) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done cexpr" end if end subroutine eval_node_compile_cexpr @ %def eval_node_compile_cexpr @ Compile a PDG-code type value. It may be either an integer expression or a variable of type PDG array, optionally quoted. <>= recursive subroutine eval_node_compile_avalue (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list if (debug_active (D_MODEL_F)) then print *, "read avalue"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("pdg_code") call eval_node_compile_pdg_code (en, pn, var_list) case ("cvariable", "variable", "prt_name") call eval_node_compile_cvariable (en, pn, var_list) case ("cexpr") call eval_node_compile_cexpr (en, pn, var_list) case ("block_cexpr") call eval_node_compile_block_expr (en, pn, var_list, V_PDG) case ("conditional_cexpr") call eval_node_compile_conditional (en, pn, var_list, V_PDG) case default call parse_node_mismatch & ("grouped_cexpr|block_cexpr|conditional_cexpr|" // & "pdg_code|cvariable|prt_name", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done avalue" end if end subroutine eval_node_compile_avalue @ %def eval_node_compile_avalue @ Compile a PDG-code expression, which is the key [[PDG]] with an integer expression as argument. The procedure is analogous to [[eval_node_compile_unary_function]]. <>= subroutine eval_node_compile_pdg_code (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_arg type(eval_node_t), pointer :: en1 type(string_t) :: key type(pdg_array_t) :: aval integer :: t if (debug_active (D_MODEL_F)) then print *, "read PDG code"; call parse_node_write (pn) end if pn_arg => parse_node_get_sub_ptr (pn, 2) call eval_node_compile_expr & (en1, parse_node_get_sub_ptr (pn_arg, tag="expr"), var_list) t = en1%result_type allocate (en) key = "PDG" if (en1%type == EN_CONSTANT) then select case (t) case (V_INT) call pdg_i (aval, en1) call eval_node_init_pdg_array (en, aval) case default; call eval_type_error (pn, char (key), t) end select call eval_node_final_rec (en1) deallocate (en1) else select case (t) case (V_INT); call eval_node_set_op1_pdg (en, pdg_i) case default; call eval_type_error (pn, char (key), t) end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done function" end if end subroutine eval_node_compile_pdg_code @ %def eval_node_compile_pdg_code @ This is entirely analogous to [[eval_node_compile_variable]]. However, PDG-array variables occur in different contexts. To avoid name clashes between PDG-array variables and ordinary variables, we prepend a character ([[*]]). This is not visible to the user. <>= subroutine eval_node_compile_cvariable (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_name type(string_t) :: var_name type(pdg_array_t), pointer :: aptr type(pdg_array_t), target, save :: no_aval logical, pointer :: known logical, target, save :: unknown = .false. if (debug_active (D_MODEL_F)) then print *, "read cvariable"; call parse_node_write (pn) end if pn_name => pn var_name = parse_node_get_string (pn_name) allocate (en) if (var_list%contains (var_name)) then call var_list%get_aptr (var_name, aptr, known) call eval_node_init_pdg_array_ptr (en, var_name, aptr, known) else call parse_node_write (pn) call msg_error ("This PDG-array variable is undefined at this point") call eval_node_init_pdg_array_ptr (en, var_name, no_aval, unknown) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done cvariable" end if end subroutine eval_node_compile_cvariable @ %def eval_node_compile_cvariable @ \subsubsection{String expressions} A string expression is either a string value or a concatenation of string values. <>= recursive subroutine eval_node_compile_sexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_svalue, pn_concatenation, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(string_t) :: string if (debug_active (D_MODEL_F)) then print *, "read sexpr"; call parse_node_write (pn) end if pn_svalue => parse_node_get_sub_ptr (pn) call eval_node_compile_svalue (en, pn_svalue, var_list) pn_concatenation => & parse_node_get_next_ptr (pn_svalue, tag="str_concatenation") do while (associated (pn_concatenation)) pn_op => parse_node_get_sub_ptr (pn_concatenation) pn_arg => parse_node_get_next_ptr (pn_op) en1 => en call eval_node_compile_svalue (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call concat_ss (string, en1, en2) call eval_node_init_string (en, string) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("concat"), V_STR, en1, en2) call eval_node_set_op2_str (en, concat_ss) end if pn_concatenation => parse_node_get_next_ptr (pn_concatenation) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done sexpr" end if end subroutine eval_node_compile_sexpr @ %def eval_node_compile_sexpr @ A string value is a string literal, a variable, a (grouped) sexpr, a block sexpr, or a conditional. <>= recursive subroutine eval_node_compile_svalue (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list if (debug_active (D_MODEL_F)) then print *, "read svalue"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("svariable") call eval_node_compile_variable (en, pn, var_list, V_STR) case ("sexpr") call eval_node_compile_sexpr (en, pn, var_list) case ("block_sexpr") call eval_node_compile_block_expr (en, pn, var_list, V_STR) case ("conditional_sexpr") call eval_node_compile_conditional (en, pn, var_list, V_STR) case ("sprintf_fun") call eval_node_compile_sprintf (en, pn, var_list) case ("string_literal") allocate (en) call eval_node_init_string (en, parse_node_get_string (pn)) case default call parse_node_mismatch & ("svariable|" // & "grouped_sexpr|block_sexpr|conditional_sexpr|" // & "string_function|string_literal", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done svalue" end if end subroutine eval_node_compile_svalue @ %def eval_node_compile_svalue @ There is currently one string function, [[sprintf]]. For [[sprintf]], the first argument (no brackets) is the format string, the optional arguments in brackets are the expressions or variables to be formatted. <>= recursive subroutine eval_node_compile_sprintf (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_clause, pn_key, pn_args type(parse_node_t), pointer :: pn_arg0 type(eval_node_t), pointer :: en0, en1 integer :: n_args type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read sprintf_fun"; call parse_node_write (pn) end if pn_clause => parse_node_get_sub_ptr (pn) pn_key => parse_node_get_sub_ptr (pn_clause) pn_arg0 => parse_node_get_next_ptr (pn_key) pn_args => parse_node_get_next_ptr (pn_clause) call eval_node_compile_sexpr (en0, pn_arg0, var_list) if (associated (pn_args)) then call eval_node_compile_sprintf_args (en1, pn_args, var_list, n_args) else n_args = 0 en1 => null () end if allocate (en) key = parse_node_get_key (pn_key) call eval_node_init_format_string (en, en0, en1, key, n_args) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done sprintf_fun" end if end subroutine eval_node_compile_sprintf @ %def eval_node_compile_sprintf <>= subroutine eval_node_compile_sprintf_args (en, pn, var_list, n_args) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(out) :: n_args type(parse_node_t), pointer :: pn_arg integer :: i type(eval_node_t), pointer :: en1, en2 n_args = parse_node_get_n_sub (pn) en => null () do i = n_args, 1, -1 pn_arg => parse_node_get_sub_ptr (pn, i) select case (char (parse_node_get_rule_key (pn_arg))) case ("lvariable") call eval_node_compile_variable (en1, pn_arg, var_list, V_LOG) case ("svariable") call eval_node_compile_variable (en1, pn_arg, var_list, V_STR) case ("expr") call eval_node_compile_expr (en1, pn_arg, var_list) case default call parse_node_mismatch ("variable|svariable|lvariable|expr", pn_arg) end select if (associated (en)) then en2 => en allocate (en) call eval_node_init_branch & (en, var_str ("sprintf_arg"), V_NONE, en1, en2) else allocate (en) call eval_node_init_branch & (en, var_str ("sprintf_arg"), V_NONE, en1) end if end do end subroutine eval_node_compile_sprintf_args @ %def eval_node_compile_sprintf_args @ Evaluation. We allocate the argument list and apply the Fortran wrapper for the [[sprintf]] function. <>= subroutine evaluate_sprintf (string, n_args, en_fmt, en_arg) type(string_t), intent(out) :: string integer, intent(in) :: n_args type(eval_node_t), pointer :: en_fmt type(eval_node_t), intent(in), optional, target :: en_arg type(eval_node_t), pointer :: en_branch, en_var type(sprintf_arg_t), dimension(:), allocatable :: arg type(string_t) :: fmt logical :: autoformat integer :: i, j, sprintf_argc autoformat = .not. associated (en_fmt) if (autoformat) fmt = "" if (present (en_arg)) then sprintf_argc = 0 en_branch => en_arg do i = 1, n_args select case (en_branch%arg1%result_type) case (V_CMPLX); sprintf_argc = sprintf_argc + 2 case default ; sprintf_argc = sprintf_argc + 1 end select en_branch => en_branch%arg2 end do allocate (arg (sprintf_argc)) j = 1 en_branch => en_arg do i = 1, n_args en_var => en_branch%arg1 select case (en_var%result_type) case (V_LOG) call sprintf_arg_init (arg(j), en_var%lval) if (autoformat) fmt = fmt // "%s " case (V_INT); call sprintf_arg_init (arg(j), en_var%ival) if (autoformat) fmt = fmt // "%i " case (V_REAL); call sprintf_arg_init (arg(j), en_var%rval) if (autoformat) fmt = fmt // "%g " case (V_STR) call sprintf_arg_init (arg(j), en_var%sval) if (autoformat) fmt = fmt // "%s " case (V_CMPLX) call sprintf_arg_init (arg(j), real (en_var%cval, default)) j = j + 1 call sprintf_arg_init (arg(j), aimag (en_var%cval)) if (autoformat) fmt = fmt // "(%g + %g * I) " case default call eval_node_write (en_var) call msg_error ("sprintf is implemented " & // "for logical, integer, real, and string values only") end select j = j + 1 en_branch => en_branch%arg2 end do else allocate (arg(0)) end if if (autoformat) then string = sprintf (trim (fmt), arg) else string = sprintf (en_fmt%sval, arg) end if end subroutine evaluate_sprintf @ %def evaluate_sprintf @ \subsection{Auxiliary functions for the compiler} Issue an error that the current node could not be compiled because of type mismatch: <>= subroutine eval_type_error (pn, string, t) type(parse_node_t), intent(in) :: pn character(*), intent(in) :: string integer, intent(in) :: t type(string_t) :: type select case (t) case (V_NONE); type = "(none)" case (V_LOG); type = "'logical'" case (V_INT); type = "'integer'" case (V_REAL); type = "'real'" case (V_CMPLX); type = "'complex'" case default; type = "(unknown)" end select call parse_node_write (pn) call msg_fatal (" The " // string // & " operation is not defined for the given argument type " // & char (type)) end subroutine eval_type_error @ %def eval_type_error @ If two numerics are combined, the result is integer if both arguments are integer, if one is integer and the other real or both are real, than its argument is real, otherwise complex. <>= function numeric_result_type (t1, t2) result (t) integer, intent(in) :: t1, t2 integer :: t if (t1 == V_INT .and. t2 == V_INT) then t = V_INT else if (t1 == V_INT .and. t2 == V_REAL) then t = V_REAL else if (t1 == V_REAL .and. t2 == V_INT) then t = V_REAL else if (t1 == V_REAL .and. t2 == V_REAL) then t = V_REAL else t = V_CMPLX end if end function numeric_result_type @ %def numeric_type @ \subsection{Evaluation} Evaluation is done recursively. For leaf nodes nothing is to be done. Evaluating particle-list functions: First, we evaluate the particle lists. If a condition is present, we assign the particle pointers of the condition node to the allocated particle entries in the parent node, keeping in mind that the observables in the variable stack used for the evaluation of the condition also contain pointers to these entries. Then, the assigned procedure is evaluated, which sets the subevent in the parent node. If required, the procedure evaluates the condition node once for each (pair of) particles to determine the result. <>= recursive subroutine eval_node_evaluate (en) type(eval_node_t), intent(inout) :: en logical :: exist select case (en%type) case (EN_UNARY) if (associated (en%arg1)) then call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known else en%value_is_known = .false. end if if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%op1_log (en%arg1) case (V_INT); en%ival = en%op1_int (en%arg1) case (V_REAL); en%rval = en%op1_real (en%arg1) case (V_CMPLX); en%cval = en%op1_cmplx (en%arg1) case (V_PDG); call en%op1_pdg (en%aval, en%arg1) case (V_SEV) if (associated (en%arg0)) then call en%op1_sev (en%pval, en%arg1, en%arg0) else call en%op1_sev (en%pval, en%arg1) end if case (V_STR) call en%op1_str (en%sval, en%arg1) end select end if case (EN_BINARY) if (associated (en%arg1) .and. associated (en%arg2)) then call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%value_is_known .and. en%arg2%value_is_known else en%value_is_known = .false. end if if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%op2_log (en%arg1, en%arg2) case (V_INT); en%ival = en%op2_int (en%arg1, en%arg2) case (V_REAL); en%rval = en%op2_real (en%arg1, en%arg2) case (V_CMPLX); en%cval = en%op2_cmplx (en%arg1, en%arg2) case (V_PDG) call en%op2_pdg (en%aval, en%arg1, en%arg2) case (V_SEV) if (associated (en%arg0)) then call en%op2_sev (en%pval, en%arg1, en%arg2, en%arg0) else call en%op2_sev (en%pval, en%arg1, en%arg2) end if case (V_STR) call en%op2_str (en%sval, en%arg1, en%arg2) end select end if case (EN_BLOCK) if (associated (en%arg1) .and. associated (en%arg0)) then call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg0) en%value_is_known = en%arg0%value_is_known else en%value_is_known = .false. end if if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%arg0%lval case (V_INT); en%ival = en%arg0%ival case (V_REAL); en%rval = en%arg0%rval case (V_CMPLX); en%cval = en%arg0%cval case (V_PDG); en%aval = en%arg0%aval case (V_SEV); en%pval = en%arg0%pval case (V_STR); en%sval = en%arg0%sval end select end if case (EN_CONDITIONAL) if (associated (en%arg0)) then call eval_node_evaluate (en%arg0) en%value_is_known = en%arg0%value_is_known else en%value_is_known = .false. end if if (en%arg0%value_is_known) then if (en%arg0%lval) then call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%arg1%lval case (V_INT); en%ival = en%arg1%ival case (V_REAL); en%rval = en%arg1%rval case (V_CMPLX); en%cval = en%arg1%cval case (V_PDG); en%aval = en%arg1%aval case (V_SEV); en%pval = en%arg1%pval case (V_STR); en%sval = en%arg1%sval end select end if else call eval_node_evaluate (en%arg2) en%value_is_known = en%arg2%value_is_known if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%arg2%lval case (V_INT); en%ival = en%arg2%ival case (V_REAL); en%rval = en%arg2%rval case (V_CMPLX); en%cval = en%arg2%cval case (V_PDG); en%aval = en%arg2%aval case (V_SEV); en%pval = en%arg2%pval case (V_STR); en%sval = en%arg2%sval end select end if end if end if case (EN_RECORD_CMD) exist = .true. en%lval = .false. call eval_node_evaluate (en%arg0) if (en%arg0%value_is_known) then if (associated (en%arg1)) then call eval_node_evaluate (en%arg1) if (en%arg1%value_is_known) then if (associated (en%arg2)) then call eval_node_evaluate (en%arg2) if (en%arg2%value_is_known) then if (associated (en%arg3)) then call eval_node_evaluate (en%arg3) if (en%arg3%value_is_known) then if (associated (en%arg4)) then call eval_node_evaluate (en%arg4) if (en%arg4%value_is_known) then if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & en%arg3%rval, en%arg4%rval, & weight=en%rval, exist=exist, & success=en%lval) else call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & en%arg3%rval, en%arg4%rval, & exist=exist, success=en%lval) end if end if else if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & en%arg3%rval, & weight=en%rval, exist=exist, & success=en%lval) else call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & en%arg3%rval, & exist=exist, success=en%lval) end if end if end if else if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & weight=en%rval, exist=exist, & success=en%lval) else call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & exist=exist, success=en%lval) end if end if end if else if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, & en%arg1%rval, & weight=en%rval, exist=exist, success=en%lval) else call analysis_record_data (en%arg0%sval, & en%arg1%rval, & exist=exist, success=en%lval) end if end if end if else if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, 1._default, & weight=en%rval, exist=exist, success=en%lval) else call analysis_record_data (en%arg0%sval, 1._default, & exist=exist, success=en%lval) end if end if if (.not. exist) then call msg_error ("Analysis object '" // char (en%arg0%sval) & // "' is undefined") en%arg0%value_is_known = .false. end if end if case (EN_OBS1_INT) en%ival = en%obs1_int (en%prt1) en%value_is_known = .true. case (EN_OBS2_INT) en%ival = en%obs2_int (en%prt1, en%prt2) en%value_is_known = .true. case (EN_OBS1_REAL) en%rval = en%obs1_real (en%prt1) en%value_is_known = .true. case (EN_OBS2_REAL) en%rval = en%obs2_real (en%prt1, en%prt2) en%value_is_known = .true. case (EN_PRT_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 call en%op1_sev (en%pval, en%arg1, en%arg0) else call en%op1_sev (en%pval, en%arg1) end if end if case (EN_PRT_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%value_is_known .and. en%arg2%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 call en%op2_sev (en%pval, en%arg1, en%arg2, en%arg0) else call en%op2_sev (en%pval, en%arg1, en%arg2) end if end if case (EN_EVAL_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = subevt_is_nonempty (en%arg1%pval) if (en%value_is_known) then en%arg0%index => en%index en%index = 1 en%arg0%prt1 => en%prt1 en%prt1 = subevt_get_prt (en%arg1%pval, 1) call eval_node_evaluate (en%arg0) en%rval = en%arg0%rval end if case (EN_EVAL_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & subevt_is_nonempty (en%arg1%pval) .and. & subevt_is_nonempty (en%arg2%pval) if (en%value_is_known) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 en%index = 1 call eval_pp (en%arg1, en%arg2, en%arg0, en%rval, en%value_is_known) end if case (EN_LOG_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = .true. if (en%value_is_known) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%lval = en%op1_cut (en%arg1, en%arg0) end if case (EN_LOG_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = .true. if (en%value_is_known) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 en%lval = en%op2_cut (en%arg1, en%arg2, en%arg0) end if case (EN_INT_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 call en%op1_evi (en%ival, en%arg1, en%arg0) else call en%op1_evi (en%ival, en%arg1) end if end if case (EN_INT_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%value_is_known .and. & en%arg2%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 call en%op2_evi (en%ival, en%arg1, en%arg2, en%arg0) else call en%op2_evi (en%ival, en%arg1, en%arg2) end if end if case (EN_REAL_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 call en%op1_evr (en%rval, en%arg1, en%arg0) else call en%op1_evr (en%rval, en%arg1) end if end if case (EN_REAL_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%value_is_known .and. & en%arg2%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 call en%op2_evr (en%rval, en%arg1, en%arg2, en%arg0) else call en%op2_evr (en%rval, en%arg1, en%arg2) end if end if case (EN_FORMAT_STR) if (associated (en%arg0)) then call eval_node_evaluate (en%arg0) en%value_is_known = en%arg0%value_is_known else en%value_is_known = .true. end if if (associated (en%arg1)) then call eval_node_evaluate (en%arg1) en%value_is_known = & en%value_is_known .and. en%arg1%value_is_known if (en%value_is_known) then call evaluate_sprintf (en%sval, en%ival, en%arg0, en%arg1) end if else if (en%value_is_known) then call evaluate_sprintf (en%sval, en%ival, en%arg0) end if end if end select if (debug2_active (D_MODEL_F)) then print *, "eval_node_evaluate" call eval_node_write (en) end if end subroutine eval_node_evaluate @ %def eval_node_evaluate @ \subsubsection{Test method} This is called from a unit test: initialize a particular observable. <>= procedure :: test_obs => eval_node_test_obs <>= subroutine eval_node_test_obs (node, var_list, var_name) class(eval_node_t), intent(inout) :: node type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: var_name procedure(obs_unary_int), pointer :: obs1_iptr type(prt_t), pointer :: p1 call var_list%get_obs1_iptr (var_name, obs1_iptr, p1) call eval_node_init_obs1_int_ptr (node, var_name, obs1_iptr, p1) end subroutine eval_node_test_obs @ %def eval_node_test_obs @ \subsection{Evaluation syntax} We have two different flavors of the syntax: with and without particles. <>= public :: syntax_expr public :: syntax_pexpr <>= type(syntax_t), target, save :: syntax_expr type(syntax_t), target, save :: syntax_pexpr @ %def syntax_expr syntax_pexpr @ These are for testing only and may be removed: <>= public :: syntax_expr_init public :: syntax_pexpr_init <>= subroutine syntax_expr_init () type(ifile_t) :: ifile call define_expr_syntax (ifile, particles=.false., analysis=.false.) call syntax_init (syntax_expr, ifile) call ifile_final (ifile) end subroutine syntax_expr_init subroutine syntax_pexpr_init () type(ifile_t) :: ifile call define_expr_syntax (ifile, particles=.true., analysis=.false.) call syntax_init (syntax_pexpr, ifile) call ifile_final (ifile) end subroutine syntax_pexpr_init @ %def syntax_expr_init syntax_pexpr_init <>= public :: syntax_expr_final public :: syntax_pexpr_final <>= subroutine syntax_expr_final () call syntax_final (syntax_expr) end subroutine syntax_expr_final subroutine syntax_pexpr_final () call syntax_final (syntax_pexpr) end subroutine syntax_pexpr_final @ %def syntax_expr_final syntax_pexpr_final <>= public :: syntax_pexpr_write <>= subroutine syntax_pexpr_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_pexpr, unit) end subroutine syntax_pexpr_write @ %def syntax_pexpr_write <>= public :: define_expr_syntax @ Numeric expressions. <>= subroutine define_expr_syntax (ifile, particles, analysis) type(ifile_t), intent(inout) :: ifile logical, intent(in) :: particles, analysis type(string_t) :: numeric_pexpr type(string_t) :: var_plist, var_alias if (particles) then numeric_pexpr = " | numeric_pexpr" var_plist = " | var_plist" var_alias = " | var_alias" else numeric_pexpr = "" var_plist = "" var_alias = "" end if call ifile_append (ifile, "SEQ expr = subexpr addition*") call ifile_append (ifile, "ALT subexpr = addition | term") call ifile_append (ifile, "SEQ addition = plus_or_minus term") call ifile_append (ifile, "SEQ term = factor multiplication*") call ifile_append (ifile, "SEQ multiplication = times_or_over factor") call ifile_append (ifile, "SEQ factor = value exponentiation?") call ifile_append (ifile, "SEQ exponentiation = to_the value") call ifile_append (ifile, "ALT plus_or_minus = '+' | '-'") call ifile_append (ifile, "ALT times_or_over = '*' | '/'") call ifile_append (ifile, "ALT to_the = '^' | '**'") call ifile_append (ifile, "KEY '+'") call ifile_append (ifile, "KEY '-'") call ifile_append (ifile, "KEY '*'") call ifile_append (ifile, "KEY '/'") call ifile_append (ifile, "KEY '^'") call ifile_append (ifile, "KEY '**'") call ifile_append (ifile, "ALT value = signed_value | unsigned_value") call ifile_append (ifile, "SEQ signed_value = '-' unsigned_value") call ifile_append (ifile, "ALT unsigned_value = " // & "numeric_value | constant | variable | " // & "result | " // & "grouped_expr | block_expr | conditional_expr | " // & "unary_function | binary_function" // & numeric_pexpr) call ifile_append (ifile, "ALT numeric_value = integer_value | " & // "real_value | complex_value") call ifile_append (ifile, "SEQ integer_value = integer_literal unit_expr?") call ifile_append (ifile, "SEQ real_value = real_literal unit_expr?") call ifile_append (ifile, "SEQ complex_value = complex_literal unit_expr?") call ifile_append (ifile, "INT integer_literal") call ifile_append (ifile, "REA real_literal") call ifile_append (ifile, "COM complex_literal") call ifile_append (ifile, "SEQ unit_expr = unit unit_power?") call ifile_append (ifile, "ALT unit = " // & "TeV | GeV | MeV | keV | eV | meV | " // & "nbarn | pbarn | fbarn | abarn | " // & "rad | mrad | degree | '%'") call ifile_append (ifile, "KEY TeV") call ifile_append (ifile, "KEY GeV") call ifile_append (ifile, "KEY MeV") call ifile_append (ifile, "KEY keV") call ifile_append (ifile, "KEY eV") call ifile_append (ifile, "KEY meV") call ifile_append (ifile, "KEY nbarn") call ifile_append (ifile, "KEY pbarn") call ifile_append (ifile, "KEY fbarn") call ifile_append (ifile, "KEY abarn") call ifile_append (ifile, "KEY rad") call ifile_append (ifile, "KEY mrad") call ifile_append (ifile, "KEY degree") call ifile_append (ifile, "KEY '%'") call ifile_append (ifile, "SEQ unit_power = '^' frac_expr") call ifile_append (ifile, "ALT frac_expr = frac | grouped_frac") call ifile_append (ifile, "GRO grouped_frac = ( frac_expr )") call ifile_append (ifile, "SEQ frac = signed_int div?") call ifile_append (ifile, "ALT signed_int = " & // "neg_int | pos_int | integer_literal") call ifile_append (ifile, "SEQ neg_int = '-' integer_literal") call ifile_append (ifile, "SEQ pos_int = '+' integer_literal") call ifile_append (ifile, "SEQ div = '/' integer_literal") call ifile_append (ifile, "ALT constant = pi | I") call ifile_append (ifile, "KEY pi") call ifile_append (ifile, "KEY I") call ifile_append (ifile, "IDE variable") call ifile_append (ifile, "SEQ result = result_key result_arg") call ifile_append (ifile, "ALT result_key = " // & "num_id | integral | error") call ifile_append (ifile, "KEY num_id") call ifile_append (ifile, "KEY integral") call ifile_append (ifile, "KEY error") call ifile_append (ifile, "GRO result_arg = ( process_id )") call ifile_append (ifile, "IDE process_id") call ifile_append (ifile, "SEQ unary_function = fun_unary function_arg1") call ifile_append (ifile, "SEQ binary_function = fun_binary function_arg2") call ifile_append (ifile, "ALT fun_unary = " // & "complex | real | int | nint | floor | ceiling | abs | conjg | sgn | " // & "sqrt | exp | log | log10 | " // & "sin | cos | tan | asin | acos | atan | " // & "sinh | cosh | tanh | asinh | acosh | atanh") call ifile_append (ifile, "KEY complex") call ifile_append (ifile, "KEY real") call ifile_append (ifile, "KEY int") call ifile_append (ifile, "KEY nint") call ifile_append (ifile, "KEY floor") call ifile_append (ifile, "KEY ceiling") call ifile_append (ifile, "KEY abs") call ifile_append (ifile, "KEY conjg") call ifile_append (ifile, "KEY sgn") call ifile_append (ifile, "KEY sqrt") call ifile_append (ifile, "KEY exp") call ifile_append (ifile, "KEY log") call ifile_append (ifile, "KEY log10") call ifile_append (ifile, "KEY sin") call ifile_append (ifile, "KEY cos") call ifile_append (ifile, "KEY tan") call ifile_append (ifile, "KEY asin") call ifile_append (ifile, "KEY acos") call ifile_append (ifile, "KEY atan") call ifile_append (ifile, "KEY sinh") call ifile_append (ifile, "KEY cosh") call ifile_append (ifile, "KEY tanh") call ifile_append (ifile, "KEY asinh") call ifile_append (ifile, "KEY acosh") call ifile_append (ifile, "KEY atanh") call ifile_append (ifile, "ALT fun_binary = max | min | mod | modulo") call ifile_append (ifile, "KEY max") call ifile_append (ifile, "KEY min") call ifile_append (ifile, "KEY mod") call ifile_append (ifile, "KEY modulo") call ifile_append (ifile, "ARG function_arg1 = ( expr )") call ifile_append (ifile, "ARG function_arg2 = ( expr, expr )") call ifile_append (ifile, "GRO grouped_expr = ( expr )") call ifile_append (ifile, "SEQ block_expr = let var_spec in expr") call ifile_append (ifile, "KEY let") call ifile_append (ifile, "ALT var_spec = " // & "var_num | var_int | var_real | var_complex | " // & "var_logical" // var_plist // var_alias // " | var_string") call ifile_append (ifile, "SEQ var_num = var_name '=' expr") call ifile_append (ifile, "SEQ var_int = int var_name '=' expr") call ifile_append (ifile, "SEQ var_real = real var_name '=' expr") call ifile_append (ifile, "SEQ var_complex = complex var_name '=' complex_expr") call ifile_append (ifile, "ALT complex_expr = " // & "cexpr_real | cexpr_complex") call ifile_append (ifile, "ARG cexpr_complex = ( expr, expr )") call ifile_append (ifile, "SEQ cexpr_real = expr") call ifile_append (ifile, "IDE var_name") call ifile_append (ifile, "KEY '='") call ifile_append (ifile, "KEY in") call ifile_append (ifile, "SEQ conditional_expr = " // & "if lexpr then expr maybe_elsif_expr maybe_else_expr endif") call ifile_append (ifile, "SEQ maybe_elsif_expr = elsif_expr*") call ifile_append (ifile, "SEQ maybe_else_expr = else_expr?") call ifile_append (ifile, "SEQ elsif_expr = elsif lexpr then expr") call ifile_append (ifile, "SEQ else_expr = else expr") call ifile_append (ifile, "KEY if") call ifile_append (ifile, "KEY then") call ifile_append (ifile, "KEY elsif") call ifile_append (ifile, "KEY else") call ifile_append (ifile, "KEY endif") call define_lexpr_syntax (ifile, particles, analysis) call define_sexpr_syntax (ifile) if (particles) then call define_pexpr_syntax (ifile) call define_cexpr_syntax (ifile) call define_var_plist_syntax (ifile) call define_var_alias_syntax (ifile) call define_numeric_pexpr_syntax (ifile) call define_logical_pexpr_syntax (ifile) end if end subroutine define_expr_syntax @ %def define_expr_syntax @ Logical expressions. <>= subroutine define_lexpr_syntax (ifile, particles, analysis) type(ifile_t), intent(inout) :: ifile logical, intent(in) :: particles, analysis type(string_t) :: logical_pexpr, record_cmd if (particles) then logical_pexpr = " | logical_pexpr" else logical_pexpr = "" end if if (analysis) then record_cmd = " | record_cmd" else record_cmd = "" end if call ifile_append (ifile, "SEQ lexpr = lsinglet lsequel*") call ifile_append (ifile, "SEQ lsequel = ';' lsinglet") call ifile_append (ifile, "SEQ lsinglet = lterm alternative*") call ifile_append (ifile, "SEQ alternative = or lterm") call ifile_append (ifile, "SEQ lterm = lvalue coincidence*") call ifile_append (ifile, "SEQ coincidence = and lvalue") call ifile_append (ifile, "KEY ';'") call ifile_append (ifile, "KEY or") call ifile_append (ifile, "KEY and") call ifile_append (ifile, "ALT lvalue = " // & "true | false | lvariable | negation | " // & "grouped_lexpr | block_lexpr | conditional_lexpr | " // & "compared_expr | compared_sexpr" // & logical_pexpr // record_cmd) call ifile_append (ifile, "KEY true") call ifile_append (ifile, "KEY false") call ifile_append (ifile, "SEQ lvariable = '?' alt_lvariable") call ifile_append (ifile, "KEY '?'") call ifile_append (ifile, "ALT alt_lvariable = variable | grouped_lexpr") call ifile_append (ifile, "SEQ negation = not lvalue") call ifile_append (ifile, "KEY not") call ifile_append (ifile, "GRO grouped_lexpr = ( lexpr )") call ifile_append (ifile, "SEQ block_lexpr = let var_spec in lexpr") call ifile_append (ifile, "ALT var_logical = " // & "var_logical_new | var_logical_spec") call ifile_append (ifile, "SEQ var_logical_new = logical var_logical_spec") call ifile_append (ifile, "KEY logical") call ifile_append (ifile, "SEQ var_logical_spec = '?' var_name = lexpr") call ifile_append (ifile, "SEQ conditional_lexpr = " // & "if lexpr then lexpr maybe_elsif_lexpr maybe_else_lexpr endif") call ifile_append (ifile, "SEQ maybe_elsif_lexpr = elsif_lexpr*") call ifile_append (ifile, "SEQ maybe_else_lexpr = else_lexpr?") call ifile_append (ifile, "SEQ elsif_lexpr = elsif lexpr then lexpr") call ifile_append (ifile, "SEQ else_lexpr = else lexpr") call ifile_append (ifile, "SEQ compared_expr = expr comparison+") call ifile_append (ifile, "SEQ comparison = compare expr") call ifile_append (ifile, "ALT compare = " // & "'<' | '>' | '<=' | '>=' | '==' | '<>'") call ifile_append (ifile, "KEY '<'") call ifile_append (ifile, "KEY '>'") call ifile_append (ifile, "KEY '<='") call ifile_append (ifile, "KEY '>='") call ifile_append (ifile, "KEY '=='") call ifile_append (ifile, "KEY '<>'") call ifile_append (ifile, "SEQ compared_sexpr = sexpr str_comparison+") call ifile_append (ifile, "SEQ str_comparison = str_compare sexpr") call ifile_append (ifile, "ALT str_compare = '==' | '<>'") if (analysis) then call ifile_append (ifile, "SEQ record_cmd = " // & "record_key analysis_tag record_arg?") call ifile_append (ifile, "ALT record_key = " // & "record | record_unweighted | record_excess") call ifile_append (ifile, "KEY record") call ifile_append (ifile, "KEY record_unweighted") call ifile_append (ifile, "KEY record_excess") call ifile_append (ifile, "ALT analysis_tag = analysis_id | sexpr") call ifile_append (ifile, "IDE analysis_id") call ifile_append (ifile, "ARG record_arg = ( expr+ )") end if end subroutine define_lexpr_syntax @ %def define_lexpr_syntax @ String expressions. <>= subroutine define_sexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ sexpr = svalue str_concatenation*") call ifile_append (ifile, "SEQ str_concatenation = '&' svalue") call ifile_append (ifile, "KEY '&'") call ifile_append (ifile, "ALT svalue = " // & "grouped_sexpr | block_sexpr | conditional_sexpr | " // & "svariable | string_function | string_literal") call ifile_append (ifile, "GRO grouped_sexpr = ( sexpr )") call ifile_append (ifile, "SEQ block_sexpr = let var_spec in sexpr") call ifile_append (ifile, "SEQ conditional_sexpr = " // & "if lexpr then sexpr maybe_elsif_sexpr maybe_else_sexpr endif") call ifile_append (ifile, "SEQ maybe_elsif_sexpr = elsif_sexpr*") call ifile_append (ifile, "SEQ maybe_else_sexpr = else_sexpr?") call ifile_append (ifile, "SEQ elsif_sexpr = elsif lexpr then sexpr") call ifile_append (ifile, "SEQ else_sexpr = else sexpr") call ifile_append (ifile, "SEQ svariable = '$' alt_svariable") call ifile_append (ifile, "KEY '$'") call ifile_append (ifile, "ALT alt_svariable = variable | grouped_sexpr") call ifile_append (ifile, "ALT var_string = " // & "var_string_new | var_string_spec") call ifile_append (ifile, "SEQ var_string_new = string var_string_spec") call ifile_append (ifile, "KEY string") call ifile_append (ifile, "SEQ var_string_spec = '$' var_name = sexpr") ! $ call ifile_append (ifile, "ALT string_function = sprintf_fun") call ifile_append (ifile, "SEQ sprintf_fun = sprintf_clause sprintf_args?") call ifile_append (ifile, "SEQ sprintf_clause = sprintf sexpr") call ifile_append (ifile, "KEY sprintf") call ifile_append (ifile, "ARG sprintf_args = ( sprintf_arg* )") call ifile_append (ifile, "ALT sprintf_arg = " & // "lvariable | svariable | expr") call ifile_append (ifile, "QUO string_literal = '""'...'""'") end subroutine define_sexpr_syntax @ %def define_sexpr_syntax @ Eval trees that evaluate to subevents. <>= subroutine define_pexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ pexpr = pterm pconcatenation*") call ifile_append (ifile, "SEQ pconcatenation = '&' pterm") ! call ifile_append (ifile, "KEY '&'") !!! (Key exists already) call ifile_append (ifile, "SEQ pterm = pvalue pcombination*") call ifile_append (ifile, "SEQ pcombination = '+' pvalue") ! call ifile_append (ifile, "KEY '+'") !!! (Key exists already) call ifile_append (ifile, "ALT pvalue = " // & "pexpr_src | pvariable | " // & "grouped_pexpr | block_pexpr | conditional_pexpr | " // & "prt_function") call ifile_append (ifile, "SEQ pexpr_src = prefix_cexpr") call ifile_append (ifile, "ALT prefix_cexpr = " // & "beam_prt | incoming_prt | outgoing_prt | unspecified_prt") call ifile_append (ifile, "SEQ beam_prt = beam cexpr") call ifile_append (ifile, "KEY beam") call ifile_append (ifile, "SEQ incoming_prt = incoming cexpr") call ifile_append (ifile, "KEY incoming") call ifile_append (ifile, "SEQ outgoing_prt = outgoing cexpr") call ifile_append (ifile, "KEY outgoing") call ifile_append (ifile, "SEQ unspecified_prt = cexpr") call ifile_append (ifile, "SEQ pvariable = '@' alt_pvariable") call ifile_append (ifile, "KEY '@'") call ifile_append (ifile, "ALT alt_pvariable = variable | grouped_pexpr") call ifile_append (ifile, "GRO grouped_pexpr = '[' pexpr ']'") call ifile_append (ifile, "SEQ block_pexpr = let var_spec in pexpr") call ifile_append (ifile, "SEQ conditional_pexpr = " // & "if lexpr then pexpr maybe_elsif_pexpr maybe_else_pexpr endif") call ifile_append (ifile, "SEQ maybe_elsif_pexpr = elsif_pexpr*") call ifile_append (ifile, "SEQ maybe_else_pexpr = else_pexpr?") call ifile_append (ifile, "SEQ elsif_pexpr = elsif lexpr then pexpr") call ifile_append (ifile, "SEQ else_pexpr = else pexpr") call ifile_append (ifile, "ALT prt_function = " // & "join_fun | combine_fun | collect_fun | cluster_fun | " // & "select_fun | extract_fun | sort_fun | " // & "select_b_jet_fun | select_non_b_jet_fun | " // & "select_c_jet_fun | select_light_jet_fun") call ifile_append (ifile, "SEQ join_fun = join_clause pargs2") call ifile_append (ifile, "SEQ combine_fun = combine_clause pargs2") call ifile_append (ifile, "SEQ collect_fun = collect_clause pargs1") call ifile_append (ifile, "SEQ cluster_fun = cluster_clause pargs1") call ifile_append (ifile, "SEQ select_fun = select_clause pargs1") call ifile_append (ifile, "SEQ extract_fun = extract_clause pargs1") call ifile_append (ifile, "SEQ sort_fun = sort_clause pargs1") call ifile_append (ifile, "SEQ select_b_jet_fun = " // & "select_b_jet_clause pargs1") call ifile_append (ifile, "SEQ select_non_b_jet_fun = " // & "select_non_b_jet_clause pargs1") call ifile_append (ifile, "SEQ select_c_jet_fun = " // & "select_c_jet_clause pargs1") call ifile_append (ifile, "SEQ select_light_jet_fun = " // & "select_light_jet_clause pargs1") call ifile_append (ifile, "SEQ join_clause = join condition?") call ifile_append (ifile, "SEQ combine_clause = combine condition?") call ifile_append (ifile, "SEQ collect_clause = collect condition?") call ifile_append (ifile, "SEQ cluster_clause = cluster condition?") call ifile_append (ifile, "SEQ select_clause = select condition?") call ifile_append (ifile, "SEQ extract_clause = extract position?") call ifile_append (ifile, "SEQ sort_clause = sort criterion?") call ifile_append (ifile, "SEQ select_b_jet_clause = " // & "select_b_jet condition?") call ifile_append (ifile, "SEQ select_non_b_jet_clause = " // & "select_non_b_jet condition?") call ifile_append (ifile, "SEQ select_c_jet_clause = " // & "select_c_jet condition?") call ifile_append (ifile, "SEQ select_light_jet_clause = " // & "select_light_jet condition?") call ifile_append (ifile, "KEY join") call ifile_append (ifile, "KEY combine") call ifile_append (ifile, "KEY collect") call ifile_append (ifile, "KEY cluster") call ifile_append (ifile, "KEY select") call ifile_append (ifile, "SEQ condition = if lexpr") call ifile_append (ifile, "KEY extract") call ifile_append (ifile, "SEQ position = index expr") call ifile_append (ifile, "KEY sort") call ifile_append (ifile, "KEY select_b_jet") call ifile_append (ifile, "KEY select_non_b_jet") call ifile_append (ifile, "KEY select_c_jet") call ifile_append (ifile, "KEY select_light_jet") call ifile_append (ifile, "SEQ criterion = by expr") call ifile_append (ifile, "KEY index") call ifile_append (ifile, "KEY by") call ifile_append (ifile, "ARG pargs2 = '[' pexpr, pexpr ']'") call ifile_append (ifile, "ARG pargs1 = '[' pexpr, pexpr? ']'") end subroutine define_pexpr_syntax @ %def define_pexpr_syntax @ Eval trees that evaluate to PDG-code arrays. <>= subroutine define_cexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ cexpr = avalue concatenation*") call ifile_append (ifile, "SEQ concatenation = ':' avalue") call ifile_append (ifile, "KEY ':'") call ifile_append (ifile, "ALT avalue = " // & "grouped_cexpr | block_cexpr | conditional_cexpr | " // & "variable | pdg_code | prt_name") call ifile_append (ifile, "GRO grouped_cexpr = ( cexpr )") call ifile_append (ifile, "SEQ block_cexpr = let var_spec in cexpr") call ifile_append (ifile, "SEQ conditional_cexpr = " // & "if lexpr then cexpr maybe_elsif_cexpr maybe_else_cexpr endif") call ifile_append (ifile, "SEQ maybe_elsif_cexpr = elsif_cexpr*") call ifile_append (ifile, "SEQ maybe_else_cexpr = else_cexpr?") call ifile_append (ifile, "SEQ elsif_cexpr = elsif lexpr then cexpr") call ifile_append (ifile, "SEQ else_cexpr = else cexpr") call ifile_append (ifile, "SEQ pdg_code = pdg pdg_arg") call ifile_append (ifile, "KEY pdg") call ifile_append (ifile, "ARG pdg_arg = ( expr )") call ifile_append (ifile, "QUO prt_name = '""'...'""'") end subroutine define_cexpr_syntax @ %def define_cexpr_syntax @ Extra variable types. <>= subroutine define_var_plist_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "ALT var_plist = var_plist_new | var_plist_spec") call ifile_append (ifile, "SEQ var_plist_new = subevt var_plist_spec") call ifile_append (ifile, "KEY subevt") call ifile_append (ifile, "SEQ var_plist_spec = '@' var_name '=' pexpr") end subroutine define_var_plist_syntax subroutine define_var_alias_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ var_alias = alias var_name '=' cexpr") call ifile_append (ifile, "KEY alias") end subroutine define_var_alias_syntax @ %def define_var_plist_syntax define_var_alias_syntax @ Particle-list expressions that evaluate to numeric values <>= subroutine define_numeric_pexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "ALT numeric_pexpr = " & // "eval_fun | count_fun") call ifile_append (ifile, "SEQ eval_fun = eval expr pargs1") call ifile_append (ifile, "SEQ count_fun = count_clause pargs1") call ifile_append (ifile, "SEQ count_clause = count condition?") call ifile_append (ifile, "KEY eval") call ifile_append (ifile, "KEY count") end subroutine define_numeric_pexpr_syntax @ %def define_numeric_pexpr_syntax @ Particle-list functions that evaluate to logical values. <>= subroutine define_logical_pexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "ALT logical_pexpr = " // & "all_fun | any_fun | no_fun | " // & "photon_isolation_fun") call ifile_append (ifile, "SEQ all_fun = all lexpr pargs1") call ifile_append (ifile, "SEQ any_fun = any lexpr pargs1") call ifile_append (ifile, "SEQ no_fun = no lexpr pargs1") call ifile_append (ifile, "SEQ photon_isolation_fun = " // & "photon_isolation_clause pargs2") call ifile_append (ifile, "SEQ photon_isolation_clause = " // & "photon_isolation condition?") call ifile_append (ifile, "KEY all") call ifile_append (ifile, "KEY any") call ifile_append (ifile, "KEY no") call ifile_append (ifile, "KEY photon_isolation") end subroutine define_logical_pexpr_syntax @ %def define_logical_pexpr_syntax @ All characters that can occur in expressions (apart from alphanumeric). <>= subroutine lexer_init_eval_tree (lexer, particles) type(lexer_t), intent(out) :: lexer logical, intent(in) :: particles type(keyword_list_t), pointer :: keyword_list if (particles) then keyword_list => syntax_get_keyword_list_ptr (syntax_pexpr) else keyword_list => syntax_get_keyword_list_ptr (syntax_expr) end if call lexer_init (lexer, & comment_chars = "#!", & quote_chars = '"', & quote_match = '"', & single_chars = "()[],;:&%?$@", & special_class = [ "+-*/^", "<>=~ " ] , & keyword_list = keyword_list) end subroutine lexer_init_eval_tree @ %def lexer_init_eval_tree @ \subsection{Set up appropriate parse trees} Parse an input stream as a specific flavor of expression. The appropriate expression syntax has to be available. <>= public :: parse_tree_init_expr public :: parse_tree_init_lexpr public :: parse_tree_init_pexpr public :: parse_tree_init_cexpr public :: parse_tree_init_sexpr <>= subroutine parse_tree_init_expr (parse_tree, stream, particles) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream logical, intent(in) :: particles type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, particles) call lexer_assign_stream (lexer, stream) if (particles) then call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("expr")) else call parse_tree_init & (parse_tree, syntax_expr, lexer, var_str ("expr")) end if call lexer_final (lexer) end subroutine parse_tree_init_expr subroutine parse_tree_init_lexpr (parse_tree, stream, particles) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream logical, intent(in) :: particles type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, particles) call lexer_assign_stream (lexer, stream) if (particles) then call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("lexpr")) else call parse_tree_init & (parse_tree, syntax_expr, lexer, var_str ("lexpr")) end if call lexer_final (lexer) end subroutine parse_tree_init_lexpr subroutine parse_tree_init_pexpr (parse_tree, stream) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, .true.) call lexer_assign_stream (lexer, stream) call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("pexpr")) call lexer_final (lexer) end subroutine parse_tree_init_pexpr subroutine parse_tree_init_cexpr (parse_tree, stream) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, .true.) call lexer_assign_stream (lexer, stream) call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("cexpr")) call lexer_final (lexer) end subroutine parse_tree_init_cexpr subroutine parse_tree_init_sexpr (parse_tree, stream, particles) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream logical, intent(in) :: particles type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, particles) call lexer_assign_stream (lexer, stream) if (particles) then call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("sexpr")) else call parse_tree_init & (parse_tree, syntax_expr, lexer, var_str ("sexpr")) end if call lexer_final (lexer) end subroutine parse_tree_init_sexpr @ %def parse_tree_init_expr @ %def parse_tree_init_lexpr @ %def parse_tree_init_pexpr @ %def parse_tree_init_cexpr @ %def parse_tree_init_sexpr @ \subsection{The evaluation tree} The evaluation tree contains the initial variable list and the root node. <>= public :: eval_tree_t <>= type, extends (expr_t) :: eval_tree_t private type(parse_node_t), pointer :: pn => null () type(var_list_t) :: var_list type(eval_node_t), pointer :: root => null () contains <> end type eval_tree_t @ %def eval_tree_t @ Init from stream, using a temporary parse tree. <>= procedure :: init_stream => eval_tree_init_stream <>= subroutine eval_tree_init_stream & (eval_tree, stream, var_list, subevt, result_type) class(eval_tree_t), intent(out), target :: eval_tree type(stream_t), intent(inout), target :: stream type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), target, optional :: subevt integer, intent(in), optional :: result_type type(parse_tree_t) :: parse_tree type(parse_node_t), pointer :: nd_root integer :: type type = V_REAL; if (present (result_type)) type = result_type select case (type) case (V_INT, V_REAL, V_CMPLX) call parse_tree_init_expr (parse_tree, stream, present (subevt)) case (V_LOG) call parse_tree_init_lexpr (parse_tree, stream, present (subevt)) case (V_SEV) call parse_tree_init_pexpr (parse_tree, stream) case (V_PDG) call parse_tree_init_cexpr (parse_tree, stream) case (V_STR) call parse_tree_init_sexpr (parse_tree, stream, present (subevt)) end select nd_root => parse_tree%get_root_ptr () if (associated (nd_root)) then select case (type) case (V_INT, V_REAL, V_CMPLX) call eval_tree_init_expr (eval_tree, nd_root, var_list, subevt) case (V_LOG) call eval_tree_init_lexpr (eval_tree, nd_root, var_list, subevt) case (V_SEV) call eval_tree_init_pexpr (eval_tree, nd_root, var_list, subevt) case (V_PDG) call eval_tree_init_cexpr (eval_tree, nd_root, var_list, subevt) case (V_STR) call eval_tree_init_sexpr (eval_tree, nd_root, var_list, subevt) end select end if call parse_tree_final (parse_tree) end subroutine eval_tree_init_stream @ %def eval_tree_init_stream @ API (to be superseded by the methods below): Init from a given parse-tree node. If we evaluate an expression that contains particle-list references, the original subevent has to be supplied. The initial variable list is optional. <>= procedure :: init_expr => eval_tree_init_expr procedure :: init_lexpr => eval_tree_init_lexpr procedure :: init_pexpr => eval_tree_init_pexpr procedure :: init_cexpr => eval_tree_init_cexpr procedure :: init_sexpr => eval_tree_init_sexpr <>= subroutine eval_tree_init_expr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_expr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_expr subroutine eval_tree_init_lexpr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_lexpr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_lexpr subroutine eval_tree_init_pexpr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_pexpr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_pexpr subroutine eval_tree_init_cexpr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_cexpr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_cexpr subroutine eval_tree_init_sexpr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_sexpr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_sexpr @ %def eval_tree_init_expr @ %def eval_tree_init_lexpr @ %def eval_tree_init_pexpr @ %def eval_tree_init_cexpr @ %def eval_tree_init_sexpr @ Alternative: set up the expression using the parse node that has already been stored. We assume that the [[subevt]] or any other variable that may be referred to has already been added to the local variable list. <>= procedure :: setup_expr => eval_tree_setup_expr procedure :: setup_lexpr => eval_tree_setup_lexpr procedure :: setup_pexpr => eval_tree_setup_pexpr procedure :: setup_cexpr => eval_tree_setup_cexpr procedure :: setup_sexpr => eval_tree_setup_sexpr <>= subroutine eval_tree_setup_expr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_expr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_expr subroutine eval_tree_setup_lexpr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_lexpr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_lexpr subroutine eval_tree_setup_pexpr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_pexpr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_pexpr subroutine eval_tree_setup_cexpr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_cexpr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_cexpr subroutine eval_tree_setup_sexpr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_sexpr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_sexpr @ %def eval_tree_setup_expr @ %def eval_tree_setup_lexpr @ %def eval_tree_setup_pexpr @ %def eval_tree_setup_cexpr @ %def eval_tree_setup_sexpr @ This extra API function handles numerical constant expressions only. The only nontrivial part is the optional unit. <>= procedure :: init_numeric_value => eval_tree_init_numeric_value <>= subroutine eval_tree_init_numeric_value (eval_tree, parse_node) class(eval_tree_t), intent(out), target :: eval_tree type(parse_node_t), intent(in), target :: parse_node call eval_node_compile_numeric_value (eval_tree%root, parse_node) end subroutine eval_tree_init_numeric_value @ %def eval_tree_init_numeric_value @ Initialize the variable list, linking it to a context variable list. <>= subroutine eval_tree_link_var_list (eval_tree, vars) type(eval_tree_t), intent(inout), target :: eval_tree class(vars_t), intent(in), target :: vars call eval_tree%var_list%link (vars) end subroutine eval_tree_link_var_list @ %def eval_tree_link_var_list @ Include a subevent object in the initialization. We add a pointer to this as variable [[@evt]] in the local variable list. <>= subroutine eval_tree_set_subevt (eval_tree, subevt) type(eval_tree_t), intent(inout), target :: eval_tree type(subevt_t), intent(in), target :: subevt logical, save, target :: known = .true. call var_list_append_subevt_ptr & (eval_tree%var_list, var_str ("@evt"), subevt, known, & intrinsic=.true.) end subroutine eval_tree_set_subevt @ %def eval_tree_set_subevt @ Finalizer. <>= procedure :: final => eval_tree_final <>= subroutine eval_tree_final (expr) class(eval_tree_t), intent(inout) :: expr call expr%var_list%final () if (associated (expr%root)) then call eval_node_final_rec (expr%root) deallocate (expr%root) end if end subroutine eval_tree_final @ %def eval_tree_final @ <>= procedure :: evaluate => eval_tree_evaluate <>= subroutine eval_tree_evaluate (expr) class(eval_tree_t), intent(inout) :: expr if (associated (expr%root)) then call eval_node_evaluate (expr%root) end if end subroutine eval_tree_evaluate @ %def eval_tree_evaluate @ Check if the eval tree is allocated. <>= function eval_tree_is_defined (eval_tree) result (flag) logical :: flag type(eval_tree_t), intent(in) :: eval_tree flag = associated (eval_tree%root) end function eval_tree_is_defined @ %def eval_tree_is_defined @ Check if the eval tree result is constant. <>= function eval_tree_is_constant (eval_tree) result (flag) logical :: flag type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then flag = eval_tree%root%type == EN_CONSTANT else flag = .false. end if end function eval_tree_is_constant @ %def eval_tree_is_constant @ Insert a conversion node at the root, if necessary (only for real/int conversion) <>= subroutine eval_tree_convert_result (eval_tree, result_type) type(eval_tree_t), intent(inout) :: eval_tree integer, intent(in) :: result_type if (associated (eval_tree%root)) then call insert_conversion_node (eval_tree%root, result_type) end if end subroutine eval_tree_convert_result @ %def eval_tree_convert_result @ Return the value of the top node, after evaluation. If the tree is empty, return the type of [[V_NONE]]. When extracting the value, no check for existence is done. For numeric values, the functions are safe against real/integer mismatch. <>= procedure :: is_known => eval_tree_result_is_known procedure :: get_log => eval_tree_get_log procedure :: get_int => eval_tree_get_int procedure :: get_real => eval_tree_get_real procedure :: get_cmplx => eval_tree_get_cmplx procedure :: get_pdg_array => eval_tree_get_pdg_array procedure :: get_subevt => eval_tree_get_subevt procedure :: get_string => eval_tree_get_string <>= function eval_tree_get_result_type (expr) result (type) integer :: type class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then type = expr%root%result_type else type = V_NONE end if end function eval_tree_get_result_type function eval_tree_result_is_known (expr) result (flag) logical :: flag class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then select case (expr%root%result_type) case (V_LOG, V_INT, V_REAL) flag = expr%root%value_is_known case default flag = .true. end select else flag = .false. end if end function eval_tree_result_is_known function eval_tree_result_is_known_ptr (expr) result (ptr) logical, pointer :: ptr class(eval_tree_t), intent(in) :: expr logical, target, save :: known = .true. if (associated (expr%root)) then select case (expr%root%result_type) case (V_LOG, V_INT, V_REAL) ptr => expr%root%value_is_known case default ptr => known end select else ptr => null () end if end function eval_tree_result_is_known_ptr function eval_tree_get_log (expr) result (lval) logical :: lval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) lval = expr%root%lval end function eval_tree_get_log function eval_tree_get_int (expr) result (ival) integer :: ival class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then select case (expr%root%result_type) case (V_INT); ival = expr%root%ival case (V_REAL); ival = expr%root%rval case (V_CMPLX); ival = expr%root%cval end select end if end function eval_tree_get_int function eval_tree_get_real (expr) result (rval) real(default) :: rval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then select case (expr%root%result_type) case (V_REAL); rval = expr%root%rval case (V_INT); rval = expr%root%ival case (V_CMPLX); rval = expr%root%cval end select end if end function eval_tree_get_real function eval_tree_get_cmplx (expr) result (cval) complex(default) :: cval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then select case (expr%root%result_type) case (V_CMPLX); cval = expr%root%cval case (V_REAL); cval = expr%root%rval case (V_INT); cval = expr%root%ival end select end if end function eval_tree_get_cmplx function eval_tree_get_pdg_array (expr) result (aval) type(pdg_array_t) :: aval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then aval = expr%root%aval end if end function eval_tree_get_pdg_array function eval_tree_get_subevt (expr) result (pval) type(subevt_t) :: pval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then pval = expr%root%pval end if end function eval_tree_get_subevt function eval_tree_get_string (expr) result (sval) type(string_t) :: sval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then sval = expr%root%sval end if end function eval_tree_get_string @ %def eval_tree_get_result_type @ %def eval_tree_result_is_known @ %def eval_tree_get_log eval_tree_get_int eval_tree_get_real @ %def eval_tree_get_cmplx @ %def eval_tree_get_pdg_expr @ %def eval_tree_get_pdg_array @ %def eval_tree_get_subevt @ %def eval_tree_get_string @ Return a pointer to the value of the top node. <>= function eval_tree_get_log_ptr (eval_tree) result (lval) logical, pointer :: lval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then lval => eval_tree%root%lval else lval => null () end if end function eval_tree_get_log_ptr function eval_tree_get_int_ptr (eval_tree) result (ival) integer, pointer :: ival type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then ival => eval_tree%root%ival else ival => null () end if end function eval_tree_get_int_ptr function eval_tree_get_real_ptr (eval_tree) result (rval) real(default), pointer :: rval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then rval => eval_tree%root%rval else rval => null () end if end function eval_tree_get_real_ptr function eval_tree_get_cmplx_ptr (eval_tree) result (cval) complex(default), pointer :: cval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then cval => eval_tree%root%cval else cval => null () end if end function eval_tree_get_cmplx_ptr function eval_tree_get_subevt_ptr (eval_tree) result (pval) type(subevt_t), pointer :: pval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then pval => eval_tree%root%pval else pval => null () end if end function eval_tree_get_subevt_ptr function eval_tree_get_pdg_array_ptr (eval_tree) result (aval) type(pdg_array_t), pointer :: aval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then aval => eval_tree%root%aval else aval => null () end if end function eval_tree_get_pdg_array_ptr function eval_tree_get_string_ptr (eval_tree) result (sval) type(string_t), pointer :: sval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then sval => eval_tree%root%sval else sval => null () end if end function eval_tree_get_string_ptr @ %def eval_tree_get_log_ptr eval_tree_get_int_ptr eval_tree_get_real_ptr @ %def eval_tree_get_cmplx_ptr @ %def eval_tree_get_subevt_ptr eval_tree_get_pdg_array_ptr @ %def eval_tree_get_string_ptr <>= procedure :: write => eval_tree_write <>= subroutine eval_tree_write (expr, unit, write_vars) class(eval_tree_t), intent(in) :: expr integer, intent(in), optional :: unit logical, intent(in), optional :: write_vars integer :: u logical :: vl u = given_output_unit (unit); if (u < 0) return vl = .false.; if (present (write_vars)) vl = write_vars write (u, "(1x,A)") "Evaluation tree:" if (associated (expr%root)) then call eval_node_write_rec (expr%root, unit) else write (u, "(3x,A)") "[empty]" end if if (vl) call var_list_write (expr%var_list, unit) end subroutine eval_tree_write @ %def eval_tree_write @ Use the written representation for generating an MD5 sum: <>= function eval_tree_get_md5sum (eval_tree) result (md5sum_et) character(32) :: md5sum_et type(eval_tree_t), intent(in) :: eval_tree integer :: u u = free_unit () open (unit = u, status = "scratch", action = "readwrite") call eval_tree_write (eval_tree, unit=u) rewind (u) md5sum_et = md5sum (u) close (u) end function eval_tree_get_md5sum @ %def eval_tree_get_md5sum @ \subsection{Direct evaluation} These procedures create an eval tree and evaluate it on-the-fly, returning only the final value. The evaluation must yield a well-defined value, unless the [[is_known]] flag is present, which will be set accordingly. <>= public :: eval_log public :: eval_int public :: eval_real public :: eval_cmplx public :: eval_subevt public :: eval_pdg_array public :: eval_string <>= function eval_log & (parse_node, var_list, subevt, is_known) result (lval) logical :: lval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_lexpr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. lval = eval_tree_get_log (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) lval = .false. end if call eval_tree_final (eval_tree) end function eval_log function eval_int & (parse_node, var_list, subevt, is_known) result (ival) integer :: ival type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_expr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. ival = eval_tree_get_int (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) ival = 0 end if call eval_tree_final (eval_tree) end function eval_int function eval_real & (parse_node, var_list, subevt, is_known) result (rval) real(default) :: rval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_expr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. rval = eval_tree_get_real (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) rval = 0 end if call eval_tree_final (eval_tree) end function eval_real function eval_cmplx & (parse_node, var_list, subevt, is_known) result (cval) complex(default) :: cval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_expr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. cval = eval_tree_get_cmplx (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) cval = 0 end if call eval_tree_final (eval_tree) end function eval_cmplx function eval_subevt & (parse_node, var_list, subevt, is_known) result (pval) type(subevt_t) :: pval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_pexpr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. pval = eval_tree_get_subevt (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) end if call eval_tree_final (eval_tree) end function eval_subevt function eval_pdg_array & (parse_node, var_list, subevt, is_known) result (aval) type(pdg_array_t) :: aval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_cexpr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. aval = eval_tree_get_pdg_array (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) end if call eval_tree_final (eval_tree) end function eval_pdg_array function eval_string & (parse_node, var_list, subevt, is_known) result (sval) type(string_t) :: sval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_sexpr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. sval = eval_tree_get_string (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) sval = "" end if call eval_tree_final (eval_tree) end function eval_string @ %def eval_log eval_int eval_real eval_cmplx @ %def eval_subevt eval_pdg_array eval_string @ %def eval_tree_unknown @ Here is a variant that returns numeric values of all possible kinds, the appropriate kind to be selected later: <>= public :: eval_numeric <>= subroutine eval_numeric & (parse_node, var_list, subevt, ival, rval, cval, & is_known, result_type) type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt integer, intent(out), optional :: ival real(default), intent(out), optional :: rval complex(default), intent(out), optional :: cval logical, intent(out), optional :: is_known integer, intent(out), optional :: result_type type(eval_tree_t), target :: eval_tree call eval_tree_init_expr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (ival)) ival = eval_tree_get_int (eval_tree) if (present (rval)) rval = eval_tree_get_real (eval_tree) if (present (cval)) cval = eval_tree_get_cmplx (eval_tree) if (present (is_known)) is_known = .true. else call eval_tree_unknown (eval_tree, parse_node) if (present (ival)) ival = 0 if (present (rval)) rval = 0 if (present (cval)) cval = 0 if (present (is_known)) is_known = .false. end if if (present (result_type)) & result_type = eval_tree_get_result_type (eval_tree) call eval_tree_final (eval_tree) end subroutine eval_numeric @ %def eval_numeric @ Error message with debugging info: <>= subroutine eval_tree_unknown (eval_tree, parse_node) type(eval_tree_t), intent(in) :: eval_tree type(parse_node_t), intent(in) :: parse_node call parse_node_write_rec (parse_node) call eval_tree_write (eval_tree) call msg_error ("Evaluation yields an undefined result, inserting default") end subroutine eval_tree_unknown @ %def eval_tree_unknown @ \subsection{Factory Type} Since [[eval_tree_t]] is an implementation of [[expr_t]], we also need a matching factory type and build method. <>= public :: eval_tree_factory_t <>= type, extends (expr_factory_t) :: eval_tree_factory_t private type(parse_node_t), pointer :: pn => null () contains <> end type eval_tree_factory_t @ %def eval_tree_factory_t @ Output: delegate to the output of the embedded parse node. <>= procedure :: write => eval_tree_factory_write <>= subroutine eval_tree_factory_write (expr_factory, unit) class(eval_tree_factory_t), intent(in) :: expr_factory integer, intent(in), optional :: unit if (associated (expr_factory%pn)) then call parse_node_write_rec (expr_factory%pn, unit) end if end subroutine eval_tree_factory_write @ %def eval_tree_factory_write @ Initializer: take a parse node and hide it thus from the environment. <>= procedure :: init => eval_tree_factory_init <>= subroutine eval_tree_factory_init (expr_factory, pn) class(eval_tree_factory_t), intent(out) :: expr_factory type(parse_node_t), intent(in), pointer :: pn expr_factory%pn => pn end subroutine eval_tree_factory_init @ %def eval_tree_factory_init @ Factory method: allocate expression with correct eval tree type. If the stored parse node is not associate, don't allocate. <>= procedure :: build => eval_tree_factory_build <>= subroutine eval_tree_factory_build (expr_factory, expr) class(eval_tree_factory_t), intent(in) :: expr_factory class(expr_t), intent(out), allocatable :: expr if (associated (expr_factory%pn)) then allocate (eval_tree_t :: expr) select type (expr) type is (eval_tree_t) expr%pn => expr_factory%pn end select end if end subroutine eval_tree_factory_build @ %def eval_tree_factory_build @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eval_trees_ut.f90]]>>= <> module eval_trees_ut use unit_tests use eval_trees_uti <> <> contains <> end module eval_trees_ut @ %def eval_trees_ut @ <<[[eval_trees_uti.f90]]>>= <> module eval_trees_uti <> <> use ifiles use lexers use lorentz use syntax_rules, only: syntax_write use pdg_arrays use subevents use variables use observables use eval_trees <> <> contains <> end module eval_trees_uti @ %def eval_trees_ut @ API: driver for the unit tests below. <>= public :: expressions_test <>= subroutine expressions_test (u, results) integer, intent(in) :: u type (test_results_t), intent(inout) :: results <> end subroutine expressions_test @ %def expressions_test @ Testing the routines of the expressions module. First a simple unary observable and the node evaluation. <>= call test (expressions_1, "expressions_1", & "check simple observable", & u, results) <>= public :: expressions_1 <>= subroutine expressions_1 (u) integer, intent(in) :: u type(var_list_t), pointer :: var_list => null () type(eval_node_t), pointer :: node => null () type(prt_t), pointer :: prt => null () type(string_t) :: var_name write (u, "(A)") "* Test output: Expressions" write (u, "(A)") "* Purpose: test simple observable and node evaluation" write (u, "(A)") write (u, "(A)") "* Setting a unary observable:" write (u, "(A)") allocate (var_list) allocate (prt) call var_list_set_observables_unary (var_list, prt) call var_list%write (u) write (u, "(A)") "* Evaluating the observable node:" write (u, "(A)") var_name = "PDG" allocate (node) call node%test_obs (var_list, var_name) call node%write (u) write (u, "(A)") "* Cleanup" write (u, "(A)") call node%final_rec () deallocate (node) !!! Workaround for NAGFOR 6.2 ! call var_list%final () deallocate (var_list) deallocate (prt) write (u, "(A)") write (u, "(A)") "* Test output end: expressions_1" end subroutine expressions_1 @ %def expressions_1 @ Parse a complicated expression, transfer it to a parse tree and evaluate. <>= call test (expressions_2, "expressions_2", & "check expression transfer to parse tree", & u, results) <>= public :: expressions_2 <>= subroutine expressions_2 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(stream_t) :: stream type(eval_tree_t) :: eval_tree type(string_t) :: expr_text type(var_list_t), pointer :: var_list => null () write (u, "(A)") "* Test output: Expressions" write (u, "(A)") "* Purpose: test parse routines" write (u, "(A)") call syntax_expr_init () call syntax_write (syntax_expr, u) allocate (var_list) call var_list_append_real (var_list, var_str ("tolerance"), 0._default) call var_list_append_real (var_list, var_str ("x"), -5._default) call var_list_append_int (var_list, var_str ("foo"), -27) call var_list_append_real (var_list, var_str ("mb"), 4._default) expr_text = & "let real twopi = 2 * pi in" // & " twopi * sqrt (25.d0 - mb^2)" // & " / (let int mb_or_0 = max (mb, 0) in" // & " 1 + (if -1 TeV <= x < mb_or_0 then abs(x) else x endif))" call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call var_list%write (u) call eval_tree%init_stream (stream, var_list=var_list) call eval_tree%evaluate () call eval_tree%write (u) write (u, "(A)") "* Input string:" write (u, "(A,A)") " ", char (expr_text) write (u, "(A)") write (u, "(A)") "* Cleanup" call stream_final (stream) call ifile_final (ifile) call eval_tree%final () call var_list%final () deallocate (var_list) call syntax_expr_final () write (u, "(A)") write (u, "(A)") "* Test output end: expressions_2" end subroutine expressions_2 @ %def expressions_2 @ Test a subevent expression. <>= call test (expressions_3, "expressions_3", & "check subevent expressions", & u, results) <>= public :: expressions_3 <>= subroutine expressions_3 (u) integer, intent(in) :: u type(subevt_t) :: subevt write (u, "(A)") "* Test output: Expressions" write (u, "(A)") "* Purpose: test subevent expressions" write (u, "(A)") write (u, "(A)") "* Initialize subevent:" write (u, "(A)") call subevt_init (subevt) call subevt_reset (subevt, 1) call subevt_set_incoming (subevt, 1, & 22, vector4_moving (1.e3_default, 1.e3_default, 1), & 0._default, [2]) call subevt_write (subevt, u) call subevt_reset (subevt, 4) call subevt_reset (subevt, 3) call subevt_set_incoming (subevt, 1, & 21, vector4_moving (1.e3_default, 1.e3_default, 3), & 0._default, [1]) call subevt_polarize (subevt, 1, -1) call subevt_set_outgoing (subevt, 2, & 1, vector4_moving (0._default, 1.e3_default, 3), & -1.e6_default, [7]) call subevt_set_composite (subevt, 3, & vector4_moving (-1.e3_default, 0._default, 3), & [2, 7]) call subevt_write (subevt, u) write (u, "(A)") write (u, "(A)") "* Test output end: expressions_3" end subroutine expressions_3 @ %def expressions_3 @ Test expressions from a PDG array. <>= call test (expressions_4, "expressions_4", & "check pdg array expressions", & u, results) <>= public :: expressions_4 <>= subroutine expressions_4 (u) integer, intent(in) :: u type(subevt_t), target :: subevt type(string_t) :: expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(eval_tree_t) :: eval_tree type(var_list_t), pointer :: var_list => null () type(pdg_array_t) :: aval write (u, "(A)") "* Test output: Expressions" write (u, "(A)") "* Purpose: test pdg array expressions" write (u, "(A)") write (u, "(A)") "* Initialization:" write (u, "(A)") call syntax_pexpr_init () call syntax_write (syntax_pexpr, u) allocate (var_list) call var_list_append_real (var_list, var_str ("tolerance"), 0._default) aval = 0 call var_list_append_pdg_array (var_list, var_str ("particle"), aval) aval = [11,-11] call var_list_append_pdg_array (var_list, var_str ("lepton"), aval) aval = 22 call var_list_append_pdg_array (var_list, var_str ("photon"), aval) aval = 1 call var_list_append_pdg_array (var_list, var_str ("u"), aval) call subevt_init (subevt) call subevt_reset (subevt, 6) call subevt_set_incoming (subevt, 1, & 1, vector4_moving (1._default, 1._default, 1), 0._default) call subevt_set_incoming (subevt, 2, & -1, vector4_moving (2._default, 2._default, 1), 0._default) call subevt_set_outgoing (subevt, 3, & 22, vector4_moving (3._default, 3._default, 1), 0._default) call subevt_set_outgoing (subevt, 4, & 22, vector4_moving (4._default, 4._default, 1), 0._default) call subevt_set_outgoing (subevt, 5, & 11, vector4_moving (5._default, 5._default, 1), 0._default) call subevt_set_outgoing (subevt, 6, & -11, vector4_moving (6._default, 6._default, 1), 0._default) write (u, "(A)") write (u, "(A)") "* Expression:" expr_text = & "let alias quark = pdg(1):pdg(2):pdg(3) in" // & " any E > 3 GeV " // & " [sort by - Pt " // & " [select if Index < 6 " // & " [photon:pdg(-11):pdg(3):quark " // & " & incoming particle]]]" // & " and" // & " eval Theta [extract index -1 [photon]] > 45 degree" // & " and" // & " count [incoming photon] * 3 > 0" write (u, "(A,A)") " ", char (expr_text) write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Extract the evaluation tree:" write (u, "(A)") call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call eval_tree%init_stream (stream, var_list, subevt, V_LOG) call eval_tree%write (u) call eval_tree%evaluate () write (u, "(A)") write (u, "(A)") "* Evaluate the tree:" write (u, "(A)") call eval_tree%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call stream_final (stream) call ifile_final (ifile) call eval_tree%final () call var_list%final () deallocate (var_list) call syntax_pexpr_final () write (u, "(A)") write (u, "(A)") "* Test output end: expressions_4" end subroutine expressions_4 @ %def expressions_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Physics Models} A model object represents a physics model. It contains a table of particle data, a list of parameters, and a vertex table. The list of parameters is a variable list which includes the real parameters (which are pointers to the particle data table) and PDG array variables for the particles themselves. The vertex list is used for phase-space generation, not for calculating the matrix element. The actual numeric model data are in the base type [[model_data_t]], as part of the [[qft]] section. We implement the [[model_t]] as an extension of this, for convenient direct access to the base-type methods via inheritance. (Alternatively, we could delegate these calls explicitly.) The extension contains administrative additions, such as the methods for recalculating derived data and keeping the parameter set consistent. It thus acts as a proxy of the actual model-data object towards the \whizard\ package. There are further proxy objects, such as the [[parameter_t]] array which provides the interface to the actual numeric parameters. Model definitions are read from model files. Therefore, this module contains a parser for model files. The parameter definitions (derived parameters) are Sindarin expressions. The models, as read from file, are stored in a model library which is a simple list of model definitions. For setting up a process object we should make a copy (an instance) of a model, which gets the current parameter values from the global variable list. \subsection{Module} <<[[models.f90]]>>= <> module models use, intrinsic :: iso_c_binding !NODEP! <> use kinds, only: c_default_float <> use io_units use diagnostics use md5 use os_interface use physics_defs, only: UNDEFINED use model_data use ifiles use syntax_rules use lexers use parser use pdg_arrays use variables use expr_base use eval_trees use ttv_formfactors, only: init_parameters <> <> <> <> <> <> contains <> end module models @ %def models @ \subsection{Physics Parameters} A parameter has a name, a value. Derived parameters also have a definition in terms of other parameters, which is stored as an [[eval_tree]]. External parameters are set by an external program. This parameter object should be considered as a proxy object. The parameter name and value are stored in a corresponding [[modelpar_data_t]] object which is located in a [[model_data_t]] object. The latter is a component of the [[model_t]] handler. Methods of [[parameter_t]] can be delegated to the [[par_data_t]] component. The [[block_name]] and [[block_index]] values, if nonempty, indicate the possibility of reading this parameter from a SLHA-type input file. (Within the [[parameter_t]] object, this info is just used for I/O, the actual block register is located in the parent [[model_t]] object.) The [[pn]] component is a pointer to the parameter definition inside the model parse tree. It allows us to recreate the [[eval_tree]] when making copies (instances) of the parameter object. <>= integer, parameter :: PAR_NONE = 0, PAR_UNUSED = -1 integer, parameter :: PAR_INDEPENDENT = 1, PAR_DERIVED = 2 integer, parameter :: PAR_EXTERNAL = 3 @ %def PAR_NONE PAR_INDEPENDENT PAR_DERIVED PAR_EXTERNAL PAR_UNUSED <>= type :: parameter_t private integer :: type = PAR_NONE class(modelpar_data_t), pointer :: data => null () type(string_t) :: block_name integer, dimension(:), allocatable :: block_index type(parse_node_t), pointer :: pn => null () class(expr_t), allocatable :: expr contains <> end type parameter_t @ %def parameter_t @ Initialization depends on parameter type. Independent parameters are initialized by a constant value or a constant numerical expression (which may contain a unit). Derived parameters are initialized by an arbitrary numerical expression, which makes use of the current variable list. The expression is evaluated by the function [[parameter_reset]]. This implementation supports only real parameters and real values. <>= procedure :: init_independent_value => parameter_init_independent_value procedure :: init_independent => parameter_init_independent procedure :: init_derived => parameter_init_derived procedure :: init_external => parameter_init_external procedure :: init_unused => parameter_init_unused <>= subroutine parameter_init_independent_value (par, par_data, name, value) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name real(default), intent(in) :: value par%type = PAR_INDEPENDENT par%data => par_data call par%data%init (name, value) end subroutine parameter_init_independent_value subroutine parameter_init_independent (par, par_data, name, pn) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name type(parse_node_t), intent(in), target :: pn par%type = PAR_INDEPENDENT par%pn => pn allocate (eval_tree_t :: par%expr) select type (expr => par%expr) type is (eval_tree_t) call expr%init_numeric_value (pn) end select par%data => par_data call par%data%init (name, par%expr%get_real ()) end subroutine parameter_init_independent subroutine parameter_init_derived (par, par_data, name, pn, var_list) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list par%type = PAR_DERIVED par%pn => pn allocate (eval_tree_t :: par%expr) select type (expr => par%expr) type is (eval_tree_t) call expr%init_expr (pn, var_list=var_list) end select par%data => par_data ! call par%expr%evaluate () call par%data%init (name, 0._default) end subroutine parameter_init_derived subroutine parameter_init_external (par, par_data, name) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name par%type = PAR_EXTERNAL par%data => par_data call par%data%init (name, 0._default) end subroutine parameter_init_external subroutine parameter_init_unused (par, par_data, name) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name par%type = PAR_UNUSED par%data => par_data call par%data%init (name, 0._default) end subroutine parameter_init_unused @ %def parameter_init_independent_value @ %def parameter_init_independent @ %def parameter_init_derived @ %def parameter_init_external @ %def parameter_init_unused @ The finalizer is needed for the evaluation tree in the definition. <>= procedure :: final => parameter_final <>= subroutine parameter_final (par) class(parameter_t), intent(inout) :: par if (allocated (par%expr)) then call par%expr%final () end if end subroutine parameter_final @ %def parameter_final @ All derived parameters should be recalculated if some independent parameters have changed: <>= procedure :: reset_derived => parameter_reset_derived <>= subroutine parameter_reset_derived (par) class(parameter_t), intent(inout) :: par select case (par%type) case (PAR_DERIVED) call par%expr%evaluate () par%data = par%expr%get_real () end select end subroutine parameter_reset_derived @ %def parameter_reset_derived parameter_reset_external @ Output. [We should have a formula format for the eval tree, suitable for input and output!] <>= procedure :: write => parameter_write <>= subroutine parameter_write (par, unit, write_defs) class(parameter_t), intent(in) :: par integer, intent(in), optional :: unit logical, intent(in), optional :: write_defs logical :: defs integer :: u u = given_output_unit (unit); if (u < 0) return defs = .false.; if (present (write_defs)) defs = write_defs select case (par%type) case (PAR_INDEPENDENT) write (u, "(3x,A)", advance="no") "parameter" call par%data%write (u) case (PAR_DERIVED) write (u, "(3x,A)", advance="no") "derived" call par%data%write (u) case (PAR_EXTERNAL) write (u, "(3x,A)", advance="no") "external" call par%data%write (u) case (PAR_UNUSED) write (u, "(3x,A)", advance="no") "unused" write (u, "(1x,A)", advance="no") char (par%data%get_name ()) end select select case (par%type) case (PAR_INDEPENDENT) if (allocated (par%block_index)) then write (u, "(1x,A,1x,A,*(1x,I0))") & "slha_entry", char (par%block_name), par%block_index else write (u, "(A)") end if case (PAR_DERIVED) if (defs) then call par%expr%write (unit) else write (u, "(A)") end if case default write (u, "(A)") end select end subroutine parameter_write @ %def parameter_write @ Screen output variant. Restrict output to the given parameter type. <>= procedure :: show => parameter_show <>= subroutine parameter_show (par, l, u, partype) class(parameter_t), intent(in) :: par integer, intent(in) :: l, u integer, intent(in) :: partype if (par%type == partype) then call par%data%show (l, u) end if end subroutine parameter_show @ %def parameter_show @ \subsection{SLHA block register} For the optional SLHA interface, the model record contains a register of SLHA-type block names together with index values, which point to a particular parameter. These are private types: <>= type :: slha_entry_t integer, dimension(:), allocatable :: block_index integer :: i_par = 0 end type slha_entry_t @ %def slha_entry_t <>= type :: slha_block_t type(string_t) :: name integer :: n_entry = 0 type(slha_entry_t), dimension(:), allocatable :: entry end type slha_block_t @ %def slha_block_t @ \subsection{Model Object} A model object holds all information about parameters, particles, and vertices. For models that require an external program for parameter calculation, there is the pointer to a function that does this calculation, given the set of independent and derived parameters. As explained above, the type inherits from [[model_data_t]], which is the actual storage for the model data. When reading a model, we create a parse tree. Parameter definitions are available via parse nodes. Since we may need those later when making model instances, we keep the whole parse tree in the model definition (but not in the instances). <>= public :: model_t <>= type, extends (model_data_t) :: model_t private character(32) :: md5sum = "" logical :: ufo_model = .false. type(string_t) :: ufo_path type(string_t), dimension(:), allocatable :: schemes type(string_t), allocatable :: selected_scheme type(parameter_t), dimension(:), allocatable :: par integer :: n_slha_block = 0 type(slha_block_t), dimension(:), allocatable :: slha_block integer :: max_par_name_length = 0 integer :: max_field_name_length = 0 type(var_list_t) :: var_list type(string_t) :: dlname procedure(model_init_external_parameters), nopass, pointer :: & init_external_parameters => null () type(dlaccess_t) :: dlaccess type(parse_tree_t) :: parse_tree contains <> end type model_t @ %def model_t @ This is the interface for a procedure that initializes the calculation of external parameters, given the array of all parameters. <>= abstract interface subroutine model_init_external_parameters (par) bind (C) import real(c_default_float), dimension(*), intent(inout) :: par end subroutine model_init_external_parameters end interface @ %def model_init_external_parameters @ Initialization: Specify the number of parameters, particles, vertices and allocate memory. If an associated DL library is specified, load this library. The model may already carry scheme information, so we have to save and restore the scheme number when actually initializing the [[model_data_t]] base. <>= generic :: init => model_init procedure, private :: model_init <>= subroutine model_init & (model, name, libname, os_data, n_par, n_prt, n_vtx, ufo) class(model_t), intent(inout) :: model type(string_t), intent(in) :: name, libname type(os_data_t), intent(in) :: os_data integer, intent(in) :: n_par, n_prt, n_vtx logical, intent(in), optional :: ufo type(c_funptr) :: c_fptr type(string_t) :: libpath integer :: scheme_num scheme_num = model%get_scheme_num () call model%basic_init (name, n_par, n_prt, n_vtx) if (present (ufo)) model%ufo_model = ufo call model%set_scheme_num (scheme_num) if (libname /= "") then if (.not. os_data%use_testfiles) then libpath = os_data%whizard_models_libpath_local model%dlname = os_get_dlname ( & libpath // "/" // libname, os_data, ignore=.true.) end if if (model%dlname == "") then libpath = os_data%whizard_models_libpath model%dlname = os_get_dlname (libpath // "/" // libname, os_data) end if else model%dlname = "" end if if (model%dlname /= "") then if (.not. dlaccess_is_open (model%dlaccess)) then if (logging) & call msg_message ("Loading model auxiliary library '" & // char (libpath) // "/" // char (model%dlname) // "'") call dlaccess_init (model%dlaccess, os_data%whizard_models_libpath, & model%dlname, os_data) if (dlaccess_has_error (model%dlaccess)) then call msg_message (char (dlaccess_get_error (model%dlaccess))) call msg_fatal ("Loading model auxiliary library '" & // char (model%dlname) // "' failed") return end if c_fptr = dlaccess_get_c_funptr (model%dlaccess, & var_str ("init_external_parameters")) if (dlaccess_has_error (model%dlaccess)) then call msg_message (char (dlaccess_get_error (model%dlaccess))) call msg_fatal ("Loading function from auxiliary library '" & // char (model%dlname) // "' failed") return end if call c_f_procpointer (c_fptr, model% init_external_parameters) end if end if end subroutine model_init @ %def model_init @ For a model instance, we do not attempt to load a DL library. This is the core of the full initializer above. <>= procedure, private :: basic_init => model_basic_init <>= subroutine model_basic_init (model, name, n_par, n_prt, n_vtx) class(model_t), intent(inout) :: model type(string_t), intent(in) :: name integer, intent(in) :: n_par, n_prt, n_vtx allocate (model%par (n_par)) call model%model_data_t%init (name, n_par, 0, n_prt, n_vtx) end subroutine model_basic_init @ %def model_basic_init @ Finalization: The variable list contains allocated pointers, also the parse tree. We also close the DL access object, if any, that enables external parameter calculation. <>= procedure :: final => model_final <>= subroutine model_final (model) class(model_t), intent(inout) :: model integer :: i if (allocated (model%par)) then do i = 1, size (model%par) call model%par(i)%final () end do end if call model%var_list%final (follow_link=.false.) if (model%dlname /= "") call dlaccess_final (model%dlaccess) call parse_tree_final (model%parse_tree) call model%model_data_t%final () end subroutine model_final @ %def model_final @ Output. By default, the output is in the form of an input file. If [[verbose]] is true, for each derived parameter the definition (eval tree) is displayed, and the vertex hash table is shown. <>= procedure :: write => model_write <>= subroutine model_write (model, unit, verbose, & show_md5sum, show_variables, show_parameters, & show_particles, show_vertices, show_scheme) class(model_t), intent(in) :: model integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical, intent(in), optional :: show_md5sum logical, intent(in), optional :: show_variables logical, intent(in), optional :: show_parameters logical, intent(in), optional :: show_particles logical, intent(in), optional :: show_vertices logical, intent(in), optional :: show_scheme logical :: verb, show_md5, show_par, show_var integer :: u, i u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose show_md5 = .true.; if (present (show_md5sum)) & show_md5 = show_md5sum show_par = .true.; if (present (show_parameters)) & show_par = show_parameters show_var = verb; if (present (show_variables)) & show_var = show_variables write (u, "(A,A,A)") 'model "', char (model%get_name ()), '"' if (show_md5 .and. model%md5sum /= "") & write (u, "(1x,A,A,A)") "! md5sum = '", model%md5sum, "'" if (model%is_ufo_model ()) then write (u, "(1x,A)") "! model derived from UFO source" else if (model%has_schemes ()) then write (u, "(1x,A)", advance="no") "! schemes =" do i = 1, size (model%schemes) if (i > 1) write (u, "(',')", advance="no") write (u, "(1x,A,A,A)", advance="no") & "'", char (model%schemes(i)), "'" end do write (u, *) if (allocated (model%selected_scheme)) then write (u, "(1x,A,A,A,I0,A)") & "! selected scheme = '", char (model%get_scheme ()), & "' (", model%get_scheme_num (), ")" end if end if if (show_par) then write (u, "(A)") do i = 1, size (model%par) call model%par(i)%write (u, write_defs=verbose) end do end if call model%model_data_t%write (unit, verbose, & show_md5sum, show_variables, & show_parameters=.false., & show_particles=show_particles, & show_vertices=show_vertices, & show_scheme=show_scheme) if (show_var) then write (u, "(A)") call var_list_write (model%var_list, unit, follow_link=.false.) end if end subroutine model_write @ %def model_write @ Screen output, condensed form. <>= procedure :: show => model_show <>= subroutine model_show (model, unit) class(model_t), intent(in) :: model integer, intent(in), optional :: unit integer :: i, u, l u = given_output_unit (unit) write (u, "(A,1x,A)") "Model:", char (model%get_name ()) if (model%has_schemes ()) then write (u, "(2x,A,A,A,I0,A)") "Scheme: '", & char (model%get_scheme ()), "' (", model%get_scheme_num (), ")" end if l = model%max_field_name_length call model%show_fields (l, u) l = model%max_par_name_length if (any (model%par%type == PAR_INDEPENDENT)) then write (u, "(2x,A)") "Independent parameters:" do i = 1, size (model%par) call model%par(i)%show (l, u, PAR_INDEPENDENT) end do end if if (any (model%par%type == PAR_DERIVED)) then write (u, "(2x,A)") "Derived parameters:" do i = 1, size (model%par) call model%par(i)%show (l, u, PAR_DERIVED) end do end if if (any (model%par%type == PAR_EXTERNAL)) then write (u, "(2x,A)") "External parameters:" do i = 1, size (model%par) call model%par(i)%show (l, u, PAR_EXTERNAL) end do end if if (any (model%par%type == PAR_UNUSED)) then write (u, "(2x,A)") "Unused parameters:" do i = 1, size (model%par) call model%par(i)%show (l, u, PAR_UNUSED) end do end if end subroutine model_show @ %def model_show @ Show all fields/particles. <>= procedure :: show_fields => model_show_fields <>= subroutine model_show_fields (model, l, unit) class(model_t), intent(in), target :: model integer, intent(in) :: l integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(2x,A)") "Particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) call field%show (l, u) end do end subroutine model_show_fields @ %def model_data_show_fields @ Show the list of stable, unstable, polarized, or unpolarized particles, respectively. <>= procedure :: show_stable => model_show_stable procedure :: show_unstable => model_show_unstable procedure :: show_polarized => model_show_polarized procedure :: show_unpolarized => model_show_unpolarized <>= subroutine model_show_stable (model, unit) class(model_t), intent(in), target :: model integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(A,1x)", advance="no") "Stable particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (field%is_stable (.false.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.false.)) end if if (field%has_antiparticle ()) then if (field%is_stable (.true.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.true.)) end if end if end do write (u, *) end subroutine model_show_stable subroutine model_show_unstable (model, unit) class(model_t), intent(in), target :: model integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(A,1x)", advance="no") "Unstable particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (.not. field%is_stable (.false.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.false.)) end if if (field%has_antiparticle ()) then if (.not. field%is_stable (.true.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.true.)) end if end if end do write (u, *) end subroutine model_show_unstable subroutine model_show_polarized (model, unit) class(model_t), intent(in), target :: model integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(A,1x)", advance="no") "Polarized particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (field%is_polarized (.false.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.false.)) end if if (field%has_antiparticle ()) then if (field%is_polarized (.true.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.true.)) end if end if end do write (u, *) end subroutine model_show_polarized subroutine model_show_unpolarized (model, unit) class(model_t), intent(in), target :: model integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(A,1x)", advance="no") "Unpolarized particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (.not. field%is_polarized (.false.)) then write (u, "(1x,A)", advance="no") & char (field%get_name (.false.)) end if if (field%has_antiparticle ()) then if (.not. field%is_polarized (.true.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.true.)) end if end if end do write (u, *) end subroutine model_show_unpolarized @ %def model_show_stable @ %def model_show_unstable @ %def model_show_polarized @ %def model_show_unpolarized @ Retrieve the MD5 sum of a model (actually, of the model file). <>= procedure :: get_md5sum => model_get_md5sum <>= function model_get_md5sum (model) result (md5sum) character(32) :: md5sum class(model_t), intent(in) :: model md5sum = model%md5sum end function model_get_md5sum @ %def model_get_md5sum @ Parameters are defined by an expression which may be constant or arbitrary. <>= procedure :: & set_parameter_constant => model_set_parameter_constant procedure, private :: & set_parameter_parse_node => model_set_parameter_parse_node procedure :: & set_parameter_external => model_set_parameter_external procedure :: & set_parameter_unused => model_set_parameter_unused <>= subroutine model_set_parameter_constant (model, i, name, value) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name real(default), intent(in) :: value logical, save, target :: known = .true. class(modelpar_data_t), pointer :: par_data real(default), pointer :: value_ptr par_data => model%get_par_real_ptr (i) call model%par(i)%init_independent_value (par_data, name, value) value_ptr => par_data%get_real_ptr () call var_list_append_real_ptr (model%var_list, & name, value_ptr, & is_known=known, intrinsic=.true.) model%max_par_name_length = max (model%max_par_name_length, len (name)) end subroutine model_set_parameter_constant subroutine model_set_parameter_parse_node (model, i, name, pn, constant) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name type(parse_node_t), intent(in), target :: pn logical, intent(in) :: constant logical, save, target :: known = .true. class(modelpar_data_t), pointer :: par_data real(default), pointer :: value_ptr par_data => model%get_par_real_ptr (i) if (constant) then call model%par(i)%init_independent (par_data, name, pn) else call model%par(i)%init_derived (par_data, name, pn, model%var_list) end if value_ptr => par_data%get_real_ptr () call var_list_append_real_ptr (model%var_list, & name, value_ptr, & is_known=known, locked=.not.constant, intrinsic=.true.) model%max_par_name_length = max (model%max_par_name_length, len (name)) end subroutine model_set_parameter_parse_node subroutine model_set_parameter_external (model, i, name) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name logical, save, target :: known = .true. class(modelpar_data_t), pointer :: par_data real(default), pointer :: value_ptr par_data => model%get_par_real_ptr (i) call model%par(i)%init_external (par_data, name) value_ptr => par_data%get_real_ptr () call var_list_append_real_ptr (model%var_list, & name, value_ptr, & is_known=known, locked=.true., intrinsic=.true.) model%max_par_name_length = max (model%max_par_name_length, len (name)) end subroutine model_set_parameter_external subroutine model_set_parameter_unused (model, i, name) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: par_data par_data => model%get_par_real_ptr (i) call model%par(i)%init_unused (par_data, name) call var_list_append_real (model%var_list, & name, locked=.true., intrinsic=.true.) model%max_par_name_length = max (model%max_par_name_length, len (name)) end subroutine model_set_parameter_unused @ %def model_set_parameter @ Make a copy of a parameter. We assume that the [[model_data_t]] parameter arrays have already been copied, so names and values are available in the current model, and can be used as targets. The eval tree should not be copied, since it should refer to the new variable list. The safe solution is to make use of the above initializers, which also take care of the building a new variable list. <>= procedure, private :: copy_parameter => model_copy_parameter <>= subroutine model_copy_parameter (model, i, par) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parameter_t), intent(in) :: par type(string_t) :: name real(default) :: value name = par%data%get_name () select case (par%type) case (PAR_INDEPENDENT) if (associated (par%pn)) then call model%set_parameter_parse_node (i, name, par%pn, & constant = .true.) else value = par%data%get_real () call model%set_parameter_constant (i, name, value) end if if (allocated (par%block_index)) then model%par(i)%block_name = par%block_name model%par(i)%block_index = par%block_index end if case (PAR_DERIVED) call model%set_parameter_parse_node (i, name, par%pn, & constant = .false.) case (PAR_EXTERNAL) call model%set_parameter_external (i, name) case (PAR_UNUSED) call model%set_parameter_unused (i, name) end select end subroutine model_copy_parameter @ %def model_copy_parameter @ Recalculate all derived parameters. <>= procedure :: update_parameters => model_parameters_update <>= subroutine model_parameters_update (model) class(model_t), intent(inout) :: model integer :: i real(default), dimension(:), allocatable :: par do i = 1, size (model%par) call model%par(i)%reset_derived () end do if (associated (model%init_external_parameters)) then allocate (par (model%get_n_real ())) call model%real_parameters_to_c_array (par) call model%init_external_parameters (par) call model%real_parameters_from_c_array (par) if (model%get_name() == var_str ("SM_tt_threshold")) & call set_threshold_parameters () end if contains subroutine set_threshold_parameters () real(default) :: mpole, wtop !!! !!! !!! Workaround for OS-X and BSD which do not load !!! !!! !!! the global values created previously. Therefore !!! !!! !!! a second initialization for the threshold model, !!! !!! !!! where M1S is required to compute the top mass. call init_parameters (mpole, wtop, & par(20), par(21), par(22), & par(19), par(39), par(4), par(1), & par(2), par(10), par(24), par(25), & par(23), par(26), par(27), par(29), & par(30), par(31), par(32), par(33), & par(36) > 0._default, par(28)) end subroutine set_threshold_parameters end subroutine model_parameters_update @ %def model_parameters_update @ Initialize field data with PDG long name and PDG code. <>= procedure, private :: init_field => model_init_field <>= subroutine model_init_field (model, i, longname, pdg) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: longname integer, intent(in) :: pdg type(field_data_t), pointer :: field field => model%get_field_ptr_by_index (i) call field%init (longname, pdg) end subroutine model_init_field @ %def model_init_field @ Copy field data for index [[i]] from another particle which serves as a template. The name should be the unique long name. <>= procedure, private :: copy_field => model_copy_field <>= subroutine model_copy_field (model, i, name_src) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name_src type(field_data_t), pointer :: field_src, field field_src => model%get_field_ptr (name_src) field => model%get_field_ptr_by_index (i) call field%copy_from (field_src) end subroutine model_copy_field @ %def model_copy_field @ \subsection{Model Access via Variables} Write the model variable list. <>= procedure :: write_var_list => model_write_var_list <>= subroutine model_write_var_list (model, unit, follow_link) class(model_t), intent(in) :: model integer, intent(in), optional :: unit logical, intent(in), optional :: follow_link call var_list_write (model%var_list, unit, follow_link) end subroutine model_write_var_list @ %def model_write_var_list @ Link a variable list to the model variables. <>= procedure :: link_var_list => model_link_var_list <>= subroutine model_link_var_list (model, var_list) class(model_t), intent(inout) :: model type(var_list_t), intent(in), target :: var_list call model%var_list%link (var_list) end subroutine model_link_var_list @ %def model_link_var_list @ Check if the model contains a named variable. <>= procedure :: var_exists => model_var_exists <>= function model_var_exists (model, name) result (flag) class(model_t), intent(in) :: model type(string_t), intent(in) :: name logical :: flag flag = model%var_list%contains (name, follow_link=.false.) end function model_var_exists @ %def model_var_exists @ Check if the model variable is a derived parameter, i.e., locked. <>= procedure :: var_is_locked => model_var_is_locked <>= function model_var_is_locked (model, name) result (flag) class(model_t), intent(in) :: model type(string_t), intent(in) :: name logical :: flag flag = model%var_list%is_locked (name, follow_link=.false.) end function model_var_is_locked @ %def model_var_is_locked @ Set a model parameter via the named variable. We assume that the variable exists and is writable, i.e., non-locked. We update the model and variable list, so independent and derived parameters are always synchronized. <>= procedure :: set_real => model_var_set_real <>= subroutine model_var_set_real (model, name, rval, verbose, pacified) class(model_t), intent(inout) :: model type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in), optional :: verbose, pacified call model%var_list%set_real (name, rval, & is_known=.true., ignore=.false., & verbose=verbose, model_name=model%get_name (), pacified=pacified) call model%update_parameters () end subroutine model_var_set_real @ %def model_var_set_real @ Retrieve a model parameter value. <>= procedure :: get_rval => model_var_get_rval <>= function model_var_get_rval (model, name) result (rval) class(model_t), intent(in) :: model type(string_t), intent(in) :: name real(default) :: rval rval = model%var_list%get_rval (name, follow_link=.false.) end function model_var_get_rval @ %def model_var_get_rval @ [To be deleted] Return a pointer to the variable list. <>= procedure :: get_var_list_ptr => model_get_var_list_ptr <>= function model_get_var_list_ptr (model) result (var_list) type(var_list_t), pointer :: var_list class(model_t), intent(in), target :: model var_list => model%var_list end function model_get_var_list_ptr @ %def model_get_var_list_ptr @ \subsection{UFO models} A single flag identifies a model as a UFO model. There is no other distinction, but the flag allows us to handle built-in and UFO models with the same name in parallel. <>= procedure :: is_ufo_model => model_is_ufo_model <>= function model_is_ufo_model (model) result (flag) class(model_t), intent(in) :: model logical :: flag flag = model%ufo_model end function model_is_ufo_model @ %def model_is_ufo_model @ Return the UFO path used for fetching the UFO source. <>= procedure :: get_ufo_path => model_get_ufo_path <>= function model_get_ufo_path (model) result (path) class(model_t), intent(in) :: model type(string_t) :: path if (model%ufo_model) then path = model%ufo_path else path = "" end if end function model_get_ufo_path @ %def model_get_ufo_path @ Call OMega and generate a model file from an UFO source file. We start with a file name; the model name is expected to be the base name, stripping extensions. The path search either takes [[ufo_path_requested]], or searches first in the working directory, then in a hard-coded UFO model directory. <>= subroutine model_generate_ufo (filename, os_data, ufo_path, & ufo_path_requested) type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data type(string_t), intent(out) :: ufo_path type(string_t), intent(in), optional :: ufo_path_requested type(string_t) :: model_name, omega_path, ufo_dir, ufo_init logical :: exist call get_model_name (filename, model_name) call msg_message ("Model: Generating model '" // char (model_name) & // "' from UFO sources") if (present (ufo_path_requested)) then call msg_message ("Model: Searching for UFO sources in '" & // char (ufo_path_requested) // "'") ufo_path = ufo_path_requested ufo_dir = ufo_path_requested // "/" // model_name ufo_init = ufo_dir // "/" // "__init__.py" inquire (file = char (ufo_init), exist = exist) else call msg_message ("Model: Searching for UFO sources in & &working directory") ufo_path = "." ufo_dir = ufo_path // "/" // model_name ufo_init = ufo_dir // "/" // "__init__.py" inquire (file = char (ufo_init), exist = exist) if (.not. exist) then ufo_path = char (os_data%whizard_modelpath_ufo) ufo_dir = ufo_path // "/" // model_name ufo_init = ufo_dir // "/" // "__init__.py" call msg_message ("Model: Searching for UFO sources in '" & // char (os_data%whizard_modelpath_ufo) // "'") inquire (file = char (ufo_init), exist = exist) end if end if if (exist) then call msg_message ("Model: Found UFO sources for model '" & // char (model_name) // "'") else call msg_fatal ("Model: UFO sources for model '" & // char (model_name) // "' not found") end if omega_path = os_data%whizard_omega_binpath // "/omega_UFO.opt" call os_system_call (omega_path & // " -model:UFO_dir " // ufo_dir & // " -model:exec" & // " -model:write_WHIZARD" & // " > " // filename) inquire (file = char (filename), exist = exist) if (exist) then call msg_message ("Model: Model file '" // char (filename) //& "' generated") else call msg_fatal ("Model: Model file '" // char (filename) & // "' could not be generated") end if contains subroutine get_model_name (filename, model_name) type(string_t), intent(in) :: filename type(string_t), intent(out) :: model_name type(string_t) :: string string = filename call split (string, model_name, ".") end subroutine get_model_name end subroutine model_generate_ufo @ %def model_generate_ufo @ \subsection{Scheme handling} A model can specify a set of allowed schemes that steer the setup of model variables. The model file can contain scheme-specific declarations that are selected by a [[select scheme]] clause. Scheme support is optional. If enabled, the model object contains a list of allowed schemes, and the model reader takes the active scheme as an argument. After the model has been read, the scheme is fixed and can no longer be modified. The model supports schemes if the scheme array is allocated. <>= procedure :: has_schemes => model_has_schemes <>= function model_has_schemes (model) result (flag) logical :: flag class(model_t), intent(in) :: model flag = allocated (model%schemes) end function model_has_schemes @ %def model_has_schemes @ Enable schemes: fix the list of allowed schemes. <>= procedure :: enable_schemes => model_enable_schemes <>= subroutine model_enable_schemes (model, scheme) class(model_t), intent(inout) :: model type(string_t), dimension(:), intent(in) :: scheme allocate (model%schemes (size (scheme)), source = scheme) end subroutine model_enable_schemes @ %def model_enable_schemes @ Find the scheme. Check if the scheme is allowed. The numeric index of the selected scheme is stored in the [[model_data_t]] base object. If no argument is given, select the first scheme. The numeric scheme ID will then be $1$, while a model without schemes retains $0$. <>= procedure :: set_scheme => model_set_scheme <>= subroutine model_set_scheme (model, scheme) class(model_t), intent(inout) :: model type(string_t), intent(in), optional :: scheme logical :: ok integer :: i if (model%has_schemes ()) then if (present (scheme)) then ok = .false. CHECK_SCHEME: do i = 1, size (model%schemes) if (scheme == model%schemes(i)) then allocate (model%selected_scheme, source = scheme) call model%set_scheme_num (i) ok = .true. exit CHECK_SCHEME end if end do CHECK_SCHEME if (.not. ok) then call msg_fatal & ("Model '" // char (model%get_name ()) & // "': scheme '" // char (scheme) // "' not supported") end if else allocate (model%selected_scheme, source = model%schemes(1)) call model%set_scheme_num (1) end if else if (present (scheme)) then call msg_error & ("Model '" // char (model%get_name ()) & // "' does not support schemes") end if end if end subroutine model_set_scheme @ %def model_set_scheme @ Get the scheme. Note that the base [[model_data_t]] provides a [[get_scheme_num]] getter function. <>= procedure :: get_scheme => model_get_scheme <>= function model_get_scheme (model) result (scheme) class(model_t), intent(in) :: model type(string_t) :: scheme if (allocated (model%selected_scheme)) then scheme = model%selected_scheme else scheme = "" end if end function model_get_scheme @ %def model_get_scheme @ Check if a model has been set up with a specific name and (if applicable) scheme. This helps in determining whether we need a new model object. A UFO model is considered to be distinct from a non-UFO model. We assume that if [[ufo]] is asked for, there is no scheme argument. Furthermore, if there is an [[ufo_path]] requested, it must coincide with the [[ufo_path]] of the model. If not, the model [[ufo_path]] is not checked. <>= procedure :: matches => model_matches <>= function model_matches (model, name, scheme, ufo, ufo_path) result (flag) logical :: flag class(model_t), intent(in) :: model type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical :: ufo_model ufo_model = .false.; if (present (ufo)) ufo_model = ufo if (name /= model%get_name ()) then flag = .false. else if (ufo_model .neqv. model%is_ufo_model ()) then flag = .false. else if (ufo_model) then if (present (ufo_path)) then flag = model%get_ufo_path () == ufo_path else flag = .true. end if else if (model%has_schemes ()) then if (present (scheme)) then flag = model%get_scheme () == scheme else flag = model%get_scheme_num () == 1 end if else if (present (scheme)) then flag = .false. else flag = .true. end if end function model_matches @ %def model_matches @ \subsection{SLHA-type interface} Abusing the original strict SUSY Les Houches Accord (SLHA), we support reading parameter data from some custom SLHA-type input file. To this end, the [[model]] object stores a list of model-specific block names together with information how to find a parameter in the model record, given a block name and index vector. Check if the model supports custom SLHA block info. This is the case if [[n_slha_block]] is nonzero, i.e., after SLHA block names have been parsed and registered. <>= procedure :: supports_custom_slha => model_supports_custom_slha <>= function model_supports_custom_slha (model) result (flag) class(model_t), intent(in) :: model logical :: flag flag = model%n_slha_block > 0 end function model_supports_custom_slha @ %def model_supports_custom_slha @ Return the block names for all SLHA block references. <>= procedure :: get_custom_slha_blocks => model_get_custom_slha_blocks <>= subroutine model_get_custom_slha_blocks (model, block_name) class(model_t), intent(in) :: model type(string_t), dimension(:), allocatable :: block_name integer :: i allocate (block_name (model%n_slha_block)) do i = 1, size (block_name) block_name(i) = model%slha_block(i)%name end do end subroutine model_get_custom_slha_blocks @ %def model_get_custom_slha_blocks @ This routine registers a SLHA block reference. We have the index of a (new) parameter entry and a parse node from the model file which specifies a block name and an index array. <>= subroutine model_record_slha_block_entry (model, i_par, node) class(model_t), intent(inout) :: model integer, intent(in) :: i_par type(parse_node_t), intent(in), target :: node type(parse_node_t), pointer :: node_block_name, node_index type(string_t) :: block_name integer :: n_index, i, i_block integer, dimension(:), allocatable :: block_index node_block_name => node%get_sub_ptr (2) select case (char (node_block_name%get_rule_key ())) case ("block_name") block_name = node_block_name%get_string () case ("QNUMBERS") block_name = "QNUMBERS" case default block_name = node_block_name%get_string () end select n_index = node%get_n_sub () - 2 allocate (block_index (n_index)) node_index => node_block_name%get_next_ptr () do i = 1, n_index block_index(i) = node_index%get_integer () node_index => node_index%get_next_ptr () end do i_block = 0 FIND_BLOCK: do i = 1, model%n_slha_block if (model%slha_block(i)%name == block_name) then i_block = i exit FIND_BLOCK end if end do FIND_BLOCK if (i_block == 0) then call model_add_slha_block (model, block_name) i_block = model%n_slha_block end if associate (b => model%slha_block(i_block)) call add_shla_block_entry (b, block_index, i_par) end associate model%par(i_par)%block_name = block_name model%par(i_par)%block_index = block_index end subroutine model_record_slha_block_entry @ %def model_record_slha_block_entry @ Add a new entry to the SLHA block register, increasing the array size if necessary <>= subroutine model_add_slha_block (model, block_name) class(model_t), intent(inout) :: model type(string_t), intent(in) :: block_name if (.not. allocated (model%slha_block)) allocate (model%slha_block (1)) if (model%n_slha_block == size (model%slha_block)) call grow model%n_slha_block = model%n_slha_block + 1 associate (b => model%slha_block(model%n_slha_block)) b%name = block_name allocate (b%entry (1)) end associate contains subroutine grow type(slha_block_t), dimension(:), allocatable :: b_tmp call move_alloc (model%slha_block, b_tmp) allocate (model%slha_block (2 * size (b_tmp))) model%slha_block(:size (b_tmp)) = b_tmp(:) end subroutine grow end subroutine model_add_slha_block @ %def model_add_slha_block @ Add a new entry to a block-register record. The entry establishes a pointer-target relation between an index array within the SLHA block and a parameter-data record. We increase the entry array as needed. <>= subroutine add_shla_block_entry (b, block_index, i_par) type(slha_block_t), intent(inout) :: b integer, dimension(:), intent(in) :: block_index integer, intent(in) :: i_par if (b%n_entry == size (b%entry)) call grow b%n_entry = b%n_entry + 1 associate (entry => b%entry(b%n_entry)) entry%block_index = block_index entry%i_par = i_par end associate contains subroutine grow type(slha_entry_t), dimension(:), allocatable :: entry_tmp call move_alloc (b%entry, entry_tmp) allocate (b%entry (2 * size (entry_tmp))) b%entry(:size (entry_tmp)) = entry_tmp(:) end subroutine grow end subroutine add_shla_block_entry @ %def add_slha_block_entry @ The lookup routine returns a pointer to the appropriate [[par_data]] record, if [[block_name]] and [[block_index]] are valid. The latter point to the [[slha_block_t]] register within the [[model_t]] object, if it is allocated. This should only be needed during I/O (i.e., while reading the SLHA file), so a simple linear search for each parameter should not be a performance problem. <>= procedure :: slha_lookup => model_slha_lookup <>= subroutine model_slha_lookup (model, block_name, block_index, par_data) class(model_t), intent(in) :: model type(string_t), intent(in) :: block_name integer, dimension(:), intent(in) :: block_index class(modelpar_data_t), pointer, intent(out) :: par_data integer :: i, j par_data => null () if (allocated (model%slha_block)) then do i = 1, model%n_slha_block associate (block => model%slha_block(i)) if (block%name == block_name) then do j = 1, block%n_entry associate (entry => block%entry(j)) if (size (entry%block_index) == size (block_index)) then if (all (entry%block_index == block_index)) then par_data => model%par(entry%i_par)%data return end if end if end associate end do end if end associate end do end if end subroutine model_slha_lookup @ %def model_slha_lookup @ Modify the value of a parameter, identified by block name and index array. <>= procedure :: slha_set_par => model_slha_set_par <>= subroutine model_slha_set_par (model, block_name, block_index, value) class(model_t), intent(inout) :: model type(string_t), intent(in) :: block_name integer, dimension(:), intent(in) :: block_index real(default), intent(in) :: value class(modelpar_data_t), pointer :: par_data call model%slha_lookup (block_name, block_index, par_data) if (associated (par_data)) then par_data = value end if end subroutine model_slha_set_par @ %def model_slha_set_par @ \subsection{Reading models from file} This procedure defines the model-file syntax for the parser, returning an internal file (ifile). Note that arithmetic operators are defined as keywords in the expression syntax, so we exclude them here. <>= subroutine define_model_file_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ model_def = model_name_def " // & "scheme_header parameters external_pars particles vertices") call ifile_append (ifile, "SEQ model_name_def = model model_name") call ifile_append (ifile, "KEY model") call ifile_append (ifile, "QUO model_name = '""'...'""'") call ifile_append (ifile, "SEQ scheme_header = scheme_decl?") call ifile_append (ifile, "SEQ scheme_decl = schemes '=' scheme_list") call ifile_append (ifile, "KEY schemes") call ifile_append (ifile, "LIS scheme_list = scheme_name+") call ifile_append (ifile, "QUO scheme_name = '""'...'""'") call ifile_append (ifile, "SEQ parameters = generic_par_def*") call ifile_append (ifile, "ALT generic_par_def = & ¶meter_def | derived_def | unused_def | scheme_block") call ifile_append (ifile, "SEQ parameter_def = parameter par_name " // & "'=' any_real_value slha_annotation?") call ifile_append (ifile, "ALT any_real_value = " & // "neg_real_value | pos_real_value | real_value") call ifile_append (ifile, "SEQ neg_real_value = '-' real_value") call ifile_append (ifile, "SEQ pos_real_value = '+' real_value") call ifile_append (ifile, "KEY parameter") call ifile_append (ifile, "IDE par_name") ! call ifile_append (ifile, "KEY '='") !!! Key already exists call ifile_append (ifile, "SEQ slha_annotation = " // & "slha_entry slha_block_name slha_entry_index*") call ifile_append (ifile, "KEY slha_entry") call ifile_append (ifile, "IDE slha_block_name") call ifile_append (ifile, "INT slha_entry_index") call ifile_append (ifile, "SEQ derived_def = derived par_name " // & "'=' expr") call ifile_append (ifile, "KEY derived") call ifile_append (ifile, "SEQ unused_def = unused par_name") call ifile_append (ifile, "KEY unused") call ifile_append (ifile, "SEQ external_pars = external_def*") call ifile_append (ifile, "SEQ external_def = external par_name") call ifile_append (ifile, "KEY external") call ifile_append (ifile, "SEQ scheme_block = & &scheme_block_beg scheme_block_body scheme_block_end") call ifile_append (ifile, "SEQ scheme_block_beg = select scheme") call ifile_append (ifile, "SEQ scheme_block_body = scheme_block_case*") call ifile_append (ifile, "SEQ scheme_block_case = & &scheme scheme_id parameters") call ifile_append (ifile, "ALT scheme_id = scheme_list | other") call ifile_append (ifile, "SEQ scheme_block_end = end select") call ifile_append (ifile, "KEY select") call ifile_append (ifile, "KEY scheme") call ifile_append (ifile, "KEY other") call ifile_append (ifile, "KEY end") call ifile_append (ifile, "SEQ particles = particle_def*") call ifile_append (ifile, "SEQ particle_def = particle name_def " // & "prt_pdg prt_details") call ifile_append (ifile, "KEY particle") - call ifile_append (ifile, "INT prt_pdg") + call ifile_append (ifile, "SEQ prt_pdg = signed_int") call ifile_append (ifile, "ALT prt_details = prt_src | prt_properties") call ifile_append (ifile, "SEQ prt_src = like name_def prt_properties") call ifile_append (ifile, "KEY like") call ifile_append (ifile, "SEQ prt_properties = prt_property*") call ifile_append (ifile, "ALT prt_property = " // & "parton | invisible | gauge | left | right | " // & "prt_name | prt_anti | prt_tex_name | prt_tex_anti | " // & "prt_spin | prt_isospin | prt_charge | " // & "prt_color | prt_mass | prt_width") call ifile_append (ifile, "KEY parton") call ifile_append (ifile, "KEY invisible") call ifile_append (ifile, "KEY gauge") call ifile_append (ifile, "KEY left") call ifile_append (ifile, "KEY right") call ifile_append (ifile, "SEQ prt_name = name name_def+") call ifile_append (ifile, "SEQ prt_anti = anti name_def+") call ifile_append (ifile, "SEQ prt_tex_name = tex_name name_def") call ifile_append (ifile, "SEQ prt_tex_anti = tex_anti name_def") call ifile_append (ifile, "KEY name") call ifile_append (ifile, "KEY anti") call ifile_append (ifile, "KEY tex_name") call ifile_append (ifile, "KEY tex_anti") call ifile_append (ifile, "ALT name_def = name_string | name_id") call ifile_append (ifile, "QUO name_string = '""'...'""'") call ifile_append (ifile, "IDE name_id") call ifile_append (ifile, "SEQ prt_spin = spin frac") call ifile_append (ifile, "KEY spin") call ifile_append (ifile, "SEQ prt_isospin = isospin frac") call ifile_append (ifile, "KEY isospin") call ifile_append (ifile, "SEQ prt_charge = charge frac") call ifile_append (ifile, "KEY charge") call ifile_append (ifile, "SEQ prt_color = color integer_literal") call ifile_append (ifile, "KEY color") call ifile_append (ifile, "SEQ prt_mass = mass par_name") call ifile_append (ifile, "KEY mass") call ifile_append (ifile, "SEQ prt_width = width par_name") call ifile_append (ifile, "KEY width") call ifile_append (ifile, "SEQ vertices = vertex_def*") call ifile_append (ifile, "SEQ vertex_def = vertex name_def+") call ifile_append (ifile, "KEY vertex") call define_expr_syntax (ifile, particles=.false., analysis=.false.) end subroutine define_model_file_syntax @ %def define_model_file_syntax @ The model-file syntax and lexer are fixed, therefore stored as module variables: <>= type(syntax_t), target, save :: syntax_model_file @ %def syntax_model_file <>= public :: syntax_model_file_init <>= subroutine syntax_model_file_init () type(ifile_t) :: ifile call define_model_file_syntax (ifile) call syntax_init (syntax_model_file, ifile) call ifile_final (ifile) end subroutine syntax_model_file_init @ %def syntax_model_file_init <>= subroutine lexer_init_model_file (lexer) type(lexer_t), intent(out) :: lexer call lexer_init (lexer, & comment_chars = "#!", & quote_chars = '"{', & quote_match = '"}', & single_chars = ":(),", & special_class = [ "+-*/^", "<>= " ] , & keyword_list = syntax_get_keyword_list_ptr (syntax_model_file)) end subroutine lexer_init_model_file @ %def lexer_init_model_file <>= public :: syntax_model_file_final <>= subroutine syntax_model_file_final () call syntax_final (syntax_model_file) end subroutine syntax_model_file_final @ %def syntax_model_file_final <>= public :: syntax_model_file_write <>= subroutine syntax_model_file_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_model_file, unit) end subroutine syntax_model_file_write @ %def syntax_model_file_write @ Read a model from file. Handle all syntax and respect the provided scheme. The [[ufo]] flag just says that the model object should be tagged as being derived from an UFO model. The UFO model path may be requested by the caller. If not, we use a standard path search for UFO models. There is no difference in the contents of the file or the generated model object. <>= procedure :: read => model_read <>= subroutine model_read (model, filename, os_data, exist, & scheme, ufo, ufo_path_requested, rebuild_mdl) class(model_t), intent(out), target :: model type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data logical, intent(out), optional :: exist type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path_requested logical, intent(in), optional :: rebuild_mdl type(string_t) :: file type(stream_t), target :: stream type(lexer_t) :: lexer integer :: unit character(32) :: model_md5sum type(parse_node_t), pointer :: nd_model_def, nd_model_name_def type(parse_node_t), pointer :: nd_schemes, nd_scheme_decl type(parse_node_t), pointer :: nd_parameters type(parse_node_t), pointer :: nd_external_pars type(parse_node_t), pointer :: nd_particles, nd_vertices type(string_t) :: model_name, lib_name integer :: n_parblock, n_par, i_par, n_ext, n_prt, n_vtx type(parse_node_t), pointer :: nd_par_def type(parse_node_t), pointer :: nd_ext_def type(parse_node_t), pointer :: nd_prt type(parse_node_t), pointer :: nd_vtx logical :: ufo_model, model_exist, rebuild ufo_model = .false.; if (present (ufo)) ufo_model = ufo rebuild = .true.; if (present (rebuild_mdl)) rebuild = rebuild_mdl file = filename inquire (file=char(file), exist=model_exist) if ((.not. model_exist) .and. (.not. os_data%use_testfiles)) then file = os_data%whizard_modelpath_local // "/" // filename inquire (file = char (file), exist = model_exist) end if if (.not. model_exist) then file = os_data%whizard_modelpath // "/" // filename inquire (file = char (file), exist = model_exist) end if if (ufo_model .and. rebuild) then file = filename call model_generate_ufo (filename, os_data, model%ufo_path, & ufo_path_requested=ufo_path_requested) inquire (file = char (file), exist = model_exist) end if if (.not. model_exist) then call msg_fatal ("Model file '" // char (filename) // "' not found") if (present (exist)) exist = .false. return end if if (present (exist)) exist = .true. if (logging) call msg_message ("Reading model file '" // char (file) // "'") unit = free_unit () open (file=char(file), unit=unit, action="read", status="old") model_md5sum = md5sum (unit) close (unit) call lexer_init_model_file (lexer) call stream_init (stream, char (file)) call lexer_assign_stream (lexer, stream) call parse_tree_init (model%parse_tree, syntax_model_file, lexer) call stream_final (stream) call lexer_final (lexer) nd_model_def => model%parse_tree%get_root_ptr () nd_model_name_def => parse_node_get_sub_ptr (nd_model_def) model_name = parse_node_get_string & (parse_node_get_sub_ptr (nd_model_name_def, 2)) nd_schemes => nd_model_name_def%get_next_ptr () call find_block & ("scheme_header", nd_schemes, nd_scheme_decl, nd_next=nd_parameters) call find_block & ("parameters", nd_parameters, nd_par_def, n_parblock, nd_external_pars) call find_block & ("external_pars", nd_external_pars, nd_ext_def, n_ext, nd_particles) call find_block & ("particles", nd_particles, nd_prt, n_prt, nd_vertices) call find_block & ("vertices", nd_vertices, nd_vtx, n_vtx) - + if (associated (nd_external_pars)) then lib_name = "external." // model_name else lib_name = "" end if if (associated (nd_scheme_decl)) then call handle_schemes (nd_scheme_decl, scheme) end if n_par = 0 call count_parameters (nd_par_def, n_parblock, n_par) - + call model%init & (model_name, lib_name, os_data, n_par + n_ext, n_prt, n_vtx, ufo) model%md5sum = model_md5sum if (associated (nd_par_def)) then i_par = 0 call handle_parameters (nd_par_def, n_parblock, i_par) end if if (associated (nd_ext_def)) then call handle_external (nd_ext_def, n_par, n_ext) end if call model%update_parameters () if (associated (nd_prt)) then call handle_fields (nd_prt, n_prt) end if if (associated (nd_vtx)) then call handle_vertices (nd_vtx, n_vtx) end if call model%freeze_vertices () call model%append_field_vars () contains subroutine find_block (key, nd, nd_item, n_item, nd_next) character(*), intent(in) :: key type(parse_node_t), pointer, intent(inout) :: nd type(parse_node_t), pointer, intent(out) :: nd_item integer, intent(out), optional :: n_item type(parse_node_t), pointer, intent(out), optional :: nd_next if (associated (nd)) then if (nd%get_rule_key () == key) then nd_item => nd%get_sub_ptr () if (present (n_item)) n_item = nd%get_n_sub () if (present (nd_next)) nd_next => nd%get_next_ptr () else nd_item => null () if (present (n_item)) n_item = 0 if (present (nd_next)) nd_next => nd nd => null () end if else nd_item => null () if (present (n_item)) n_item = 0 if (present (nd_next)) nd_next => null () end if end subroutine find_block subroutine handle_schemes (nd_scheme_decl, scheme) type(parse_node_t), pointer, intent(in) :: nd_scheme_decl type(string_t), intent(in), optional :: scheme type(parse_node_t), pointer :: nd_list, nd_entry type(string_t), dimension(:), allocatable :: schemes integer :: i, n_schemes nd_list => nd_scheme_decl%get_sub_ptr (3) nd_entry => nd_list%get_sub_ptr () n_schemes = nd_list%get_n_sub () allocate (schemes (n_schemes)) do i = 1, n_schemes schemes(i) = nd_entry%get_string () nd_entry => nd_entry%get_next_ptr () end do if (present (scheme)) then do i = 1, n_schemes if (schemes(i) == scheme) goto 10 ! block exit end do call msg_fatal ("Scheme '" // char (scheme) & // "' is not supported by model '" // char (model_name) // "'") end if 10 continue call model%enable_schemes (schemes) call model%set_scheme (scheme) end subroutine handle_schemes subroutine select_scheme (nd_scheme_block, n_parblock_sub, nd_par_def) type(parse_node_t), pointer, intent(in) :: nd_scheme_block integer, intent(out) :: n_parblock_sub type(parse_node_t), pointer, intent(out) :: nd_par_def type(parse_node_t), pointer :: nd_scheme_body type(parse_node_t), pointer :: nd_scheme_case, nd_scheme_id, nd_scheme type(string_t) :: scheme integer :: n_cases, i scheme = model%get_scheme () nd_scheme_body => nd_scheme_block%get_sub_ptr (2) nd_parameters => null () select case (char (nd_scheme_body%get_rule_key ())) case ("scheme_block_body") n_cases = nd_scheme_body%get_n_sub () FIND_SCHEME: do i = 1, n_cases nd_scheme_case => nd_scheme_body%get_sub_ptr (i) nd_scheme_id => nd_scheme_case%get_sub_ptr (2) select case (char (nd_scheme_id%get_rule_key ())) case ("scheme_list") nd_scheme => nd_scheme_id%get_sub_ptr () do while (associated (nd_scheme)) if (scheme == nd_scheme%get_string ()) then nd_parameters => nd_scheme_id%get_next_ptr () exit FIND_SCHEME end if nd_scheme => nd_scheme%get_next_ptr () end do case ("other") nd_parameters => nd_scheme_id%get_next_ptr () exit FIND_SCHEME case default print *, "'", char (nd_scheme_id%get_rule_key ()), "'" call msg_bug ("Model read: impossible scheme rule") end select end do FIND_SCHEME end select if (associated (nd_parameters)) then select case (char (nd_parameters%get_rule_key ())) case ("parameters") n_parblock_sub = nd_parameters%get_n_sub () if (n_parblock_sub > 0) then nd_par_def => nd_parameters%get_sub_ptr () else nd_par_def => null () end if case default n_parblock_sub = 0 nd_par_def => null () end select else n_parblock_sub = 0 nd_par_def => null () end if end subroutine select_scheme recursive subroutine count_parameters (nd_par_def_in, n_parblock, n_par) type(parse_node_t), pointer, intent(in) :: nd_par_def_in integer, intent(in) :: n_parblock integer, intent(inout) :: n_par type(parse_node_t), pointer :: nd_par_def, nd_par_key type(parse_node_t), pointer :: nd_par_def_sub integer :: n_parblock_sub integer :: i nd_par_def => nd_par_def_in do i = 1, n_parblock nd_par_key => nd_par_def%get_sub_ptr () select case (char (nd_par_key%get_rule_key ())) case ("parameter", "derived", "unused") n_par = n_par + 1 case ("scheme_block_beg") call select_scheme (nd_par_def, n_parblock_sub, nd_par_def_sub) if (n_parblock_sub > 0) then call count_parameters (nd_par_def_sub, n_parblock_sub, n_par) end if case default print *, "'", char (nd_par_key%get_rule_key ()), "'" call msg_bug ("Model read: impossible parameter rule") end select nd_par_def => parse_node_get_next_ptr (nd_par_def) end do end subroutine count_parameters recursive subroutine handle_parameters (nd_par_def_in, n_parblock, i_par) type(parse_node_t), pointer, intent(in) :: nd_par_def_in integer, intent(in) :: n_parblock integer, intent(inout) :: i_par type(parse_node_t), pointer :: nd_par_def, nd_par_key type(parse_node_t), pointer :: nd_par_def_sub integer :: n_parblock_sub integer :: i nd_par_def => nd_par_def_in do i = 1, n_parblock nd_par_key => nd_par_def%get_sub_ptr () select case (char (nd_par_key%get_rule_key ())) case ("parameter") i_par = i_par + 1 call model%read_parameter (i_par, nd_par_def) case ("derived") i_par = i_par + 1 call model%read_derived (i_par, nd_par_def) case ("unused") i_par = i_par + 1 call model%read_unused (i_par, nd_par_def) case ("scheme_block_beg") call select_scheme (nd_par_def, n_parblock_sub, nd_par_def_sub) if (n_parblock_sub > 0) then call handle_parameters (nd_par_def_sub, n_parblock_sub, i_par) end if end select nd_par_def => parse_node_get_next_ptr (nd_par_def) end do end subroutine handle_parameters subroutine handle_external (nd_ext_def, n_par, n_ext) type(parse_node_t), pointer, intent(inout) :: nd_ext_def integer, intent(in) :: n_par, n_ext integer :: i do i = n_par + 1, n_par + n_ext call model%read_external (i, nd_ext_def) nd_ext_def => parse_node_get_next_ptr (nd_ext_def) end do ! real(c_default_float), dimension(:), allocatable :: par ! if (associated (model%init_external_parameters)) then ! allocate (par (model%get_n_real ())) ! call model%real_parameters_to_c_array (par) ! call model%init_external_parameters (par) ! call model%real_parameters_from_c_array (par) ! end if end subroutine handle_external subroutine handle_fields (nd_prt, n_prt) type(parse_node_t), pointer, intent(inout) :: nd_prt integer, intent(in) :: n_prt integer :: i do i = 1, n_prt call model%read_field (i, nd_prt) nd_prt => parse_node_get_next_ptr (nd_prt) end do end subroutine handle_fields subroutine handle_vertices (nd_vtx, n_vtx) type(parse_node_t), pointer, intent(inout) :: nd_vtx integer, intent(in) :: n_vtx integer :: i do i = 1, n_vtx call model%read_vertex (i, nd_vtx) nd_vtx => parse_node_get_next_ptr (nd_vtx) end do end subroutine handle_vertices end subroutine model_read @ %def model_read @ Parameters are real values (literal) with an optional unit. <>= procedure, private :: read_parameter => model_read_parameter <>= subroutine model_read_parameter (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in), target :: node type(parse_node_t), pointer :: node_name, node_val, node_slha_entry type(string_t) :: name node_name => parse_node_get_sub_ptr (node, 2) name = parse_node_get_string (node_name) node_val => parse_node_get_next_ptr (node_name, 2) call model%set_parameter_parse_node (i, name, node_val, constant=.true.) node_slha_entry => parse_node_get_next_ptr (node_val) if (associated (node_slha_entry)) then call model_record_slha_block_entry (model, i, node_slha_entry) end if end subroutine model_read_parameter @ %def model_read_parameter @ Derived parameters have any numeric expression as their definition. Don't evaluate the expression, yet. <>= procedure, private :: read_derived => model_read_derived <>= subroutine model_read_derived (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in), target :: node type(string_t) :: name type(parse_node_t), pointer :: pn_expr name = parse_node_get_string (parse_node_get_sub_ptr (node, 2)) pn_expr => parse_node_get_sub_ptr (node, 4) call model%set_parameter_parse_node (i, name, pn_expr, constant=.false.) end subroutine model_read_derived @ %def model_read_derived @ External parameters have no definition; they are handled by an external library. <>= procedure, private :: read_external => model_read_external <>= subroutine model_read_external (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in), target :: node type(string_t) :: name name = parse_node_get_string (parse_node_get_sub_ptr (node, 2)) call model%set_parameter_external (i, name) end subroutine model_read_external @ %def model_read_external @ Ditto for unused parameters, they are there just for reserving the name. <>= procedure, private :: read_unused => model_read_unused <>= subroutine model_read_unused (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in), target :: node type(string_t) :: name name = parse_node_get_string (parse_node_get_sub_ptr (node, 2)) call model%set_parameter_unused (i, name) end subroutine model_read_unused @ %def model_read_unused <>= procedure, private :: read_field => model_read_field <>= subroutine model_read_field (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in) :: node type(parse_node_t), pointer :: nd_src, nd_props, nd_prop type(string_t) :: longname integer :: pdg type(string_t) :: name_src type(string_t), dimension(:), allocatable :: name type(field_data_t), pointer :: field, field_src longname = parse_node_get_string (parse_node_get_sub_ptr (node, 2)) - pdg = parse_node_get_integer (parse_node_get_sub_ptr (node, 3)) + pdg = read_frac (parse_node_get_sub_ptr (node, 3)) field => model%get_field_ptr_by_index (i) call field%init (longname, pdg) nd_src => parse_node_get_sub_ptr (node, 4) if (associated (nd_src)) then if (parse_node_get_rule_key (nd_src) == "prt_src") then name_src = parse_node_get_string (parse_node_get_sub_ptr (nd_src, 2)) field_src => model%get_field_ptr (name_src, check=.true.) call field%copy_from (field_src) nd_props => parse_node_get_sub_ptr (nd_src, 3) else nd_props => nd_src end if nd_prop => parse_node_get_sub_ptr (nd_props) do while (associated (nd_prop)) select case (char (parse_node_get_rule_key (nd_prop))) case ("invisible") call field%set (is_visible=.false.) case ("parton") call field%set (is_parton=.true.) case ("gauge") call field%set (is_gauge=.true.) case ("left") call field%set (is_left_handed=.true.) case ("right") call field%set (is_right_handed=.true.) case ("prt_name") call read_names (nd_prop, name) call field%set (name=name) case ("prt_anti") call read_names (nd_prop, name) call field%set (anti=name) case ("prt_tex_name") call field%set ( & tex_name = parse_node_get_string & (parse_node_get_sub_ptr (nd_prop, 2))) case ("prt_tex_anti") call field%set ( & tex_anti = parse_node_get_string & (parse_node_get_sub_ptr (nd_prop, 2))) case ("prt_spin") call field%set ( & spin_type = read_frac & (parse_node_get_sub_ptr (nd_prop, 2), 2)) case ("prt_isospin") call field%set ( & isospin_type = read_frac & (parse_node_get_sub_ptr (nd_prop, 2), 2)) case ("prt_charge") call field%set ( & charge_type = read_frac & (parse_node_get_sub_ptr (nd_prop, 2), 3)) case ("prt_color") call field%set ( & color_type = parse_node_get_integer & (parse_node_get_sub_ptr (nd_prop, 2))) case ("prt_mass") call field%set ( & mass_data = model%get_par_data_ptr & (parse_node_get_string & (parse_node_get_sub_ptr (nd_prop, 2)))) case ("prt_width") call field%set ( & width_data = model%get_par_data_ptr & (parse_node_get_string & (parse_node_get_sub_ptr (nd_prop, 2)))) case default call msg_bug (" Unknown particle property '" & // char (parse_node_get_rule_key (nd_prop)) // "'") end select if (allocated (name)) deallocate (name) nd_prop => parse_node_get_next_ptr (nd_prop) end do end if call field%freeze () end subroutine model_read_field @ %def model_read_field <>= procedure, private :: read_vertex => model_read_vertex <>= subroutine model_read_vertex (model, i, node) class(model_t), intent(inout) :: model integer, intent(in) :: i type(parse_node_t), intent(in) :: node type(string_t), dimension(:), allocatable :: name call read_names (node, name) call model%set_vertex (i, name) end subroutine model_read_vertex @ %def model_read_vertex <>= subroutine read_names (node, name) type(parse_node_t), intent(in) :: node type(string_t), dimension(:), allocatable, intent(inout) :: name type(parse_node_t), pointer :: nd_name integer :: n_names, i n_names = parse_node_get_n_sub (node) - 1 allocate (name (n_names)) nd_name => parse_node_get_sub_ptr (node, 2) do i = 1, n_names name(i) = parse_node_get_string (nd_name) nd_name => parse_node_get_next_ptr (nd_name) end do end subroutine read_names @ %def read_names +@ There is an optional argument for the base. <>= function read_frac (nd_frac, base) result (qn_type) integer :: qn_type type(parse_node_t), intent(in) :: nd_frac - integer, intent(in) :: base + integer, intent(in), optional :: base type(parse_node_t), pointer :: nd_num, nd_den integer :: num, den nd_num => parse_node_get_sub_ptr (nd_frac) nd_den => parse_node_get_next_ptr (nd_num) select case (char (parse_node_get_rule_key (nd_num))) case ("integer_literal") num = parse_node_get_integer (nd_num) case ("neg_int") num = - parse_node_get_integer (parse_node_get_sub_ptr (nd_num, 2)) case ("pos_int") num = parse_node_get_integer (parse_node_get_sub_ptr (nd_num, 2)) case default call parse_tree_bug (nd_num, "int|neg_int|pos_int") end select if (associated (nd_den)) then den = parse_node_get_integer (parse_node_get_sub_ptr (nd_den, 2)) else den = 1 end if - if (den == 1) then - qn_type = sign (1 + abs (num) * base, num) - else if (den == base) then - qn_type = sign (abs (num) + 1, num) + if (present (base)) then + if (den == 1) then + qn_type = sign (1 + abs (num) * base, num) + else if (den == base) then + qn_type = sign (abs (num) + 1, num) + else + call parse_node_write_rec (nd_frac) + call msg_fatal (" Fractional quantum number: wrong denominator") + end if else - call parse_node_write_rec (nd_frac) - call msg_fatal (" Fractional quantum number: wrong denominator") + if (den == 1) then + qn_type = num + else + call parse_node_write_rec (nd_frac) + call msg_fatal (" Wrong type: no fraction expected") + end if end if end function read_frac @ %def read_frac @ Append field (PDG-array) variables to the variable list, based on the field content. <>= procedure, private :: append_field_vars => model_append_field_vars <>= subroutine model_append_field_vars (model) class(model_t), intent(inout) :: model type(pdg_array_t) :: aval type(field_data_t), dimension(:), pointer :: field_array type(field_data_t), pointer :: field type(string_t) :: name type(string_t), dimension(:), allocatable :: name_array integer, dimension(:), allocatable :: pdg logical, dimension(:), allocatable :: mask integer :: i, j field_array => model%get_field_array_ptr () aval = UNDEFINED call var_list_append_pdg_array & (model%var_list, var_str ("particle"), & aval, locked = .true., intrinsic=.true.) do i = 1, size (field_array) aval = field_array(i)%get_pdg () name = field_array(i)%get_longname () call var_list_append_pdg_array & (model%var_list, name, aval, locked=.true., intrinsic=.true.) call field_array(i)%get_name_array (.false., name_array) do j = 1, size (name_array) call var_list_append_pdg_array & (model%var_list, name_array(j), & aval, locked=.true., intrinsic=.true.) end do model%max_field_name_length = & max (model%max_field_name_length, len (name_array(1))) aval = - field_array(i)%get_pdg () call field_array(i)%get_name_array (.true., name_array) do j = 1, size (name_array) call var_list_append_pdg_array & (model%var_list, name_array(j), & aval, locked=.true., intrinsic=.true.) end do if (size (name_array) > 0) then model%max_field_name_length = & max (model%max_field_name_length, len (name_array(1))) end if end do call model%get_all_pdg (pdg) allocate (mask (size (pdg))) do i = 1, size (pdg) field => model%get_field_ptr (pdg(i)) mask(i) = field%get_charge_type () /= 1 end do aval = pack (pdg, mask) call var_list_append_pdg_array & (model%var_list, var_str ("charged"), & aval, locked = .true., intrinsic=.true.) do i = 1, size (pdg) field => model%get_field_ptr (pdg(i)) mask(i) = field%get_charge_type () == 1 end do aval = pack (pdg, mask) call var_list_append_pdg_array & (model%var_list, var_str ("neutral"), & aval, locked = .true., intrinsic=.true.) do i = 1, size (pdg) field => model%get_field_ptr (pdg(i)) mask(i) = field%get_color_type () /= 1 end do aval = pack (pdg, mask) call var_list_append_pdg_array & (model%var_list, var_str ("colored"), & aval, locked = .true., intrinsic=.true.) end subroutine model_append_field_vars @ %def model_append_field_vars @ \subsection{Test models} <>= public :: create_test_model <>= subroutine create_test_model (model_name, test_model) type(string_t), intent(in) :: model_name type(model_t), intent(out), pointer :: test_model type(os_data_t) :: os_data type(model_list_t) :: model_list call syntax_model_file_init () call os_data%init () call model_list%read_model & (model_name, model_name // var_str (".mdl"), os_data, test_model) end subroutine create_test_model @ %def create_test_model @ \subsection{Model list} List of currently active models <>= type, extends (model_t) :: model_entry_t type(model_entry_t), pointer :: next => null () end type model_entry_t @ %def model_entry_t <>= public :: model_list_t <>= type :: model_list_t type(model_entry_t), pointer :: first => null () type(model_entry_t), pointer :: last => null () type(model_list_t), pointer :: context => null () contains <> end type model_list_t @ %def model_list_t @ Write an account of the model list. We write linked lists first, starting from the global context. <>= procedure :: write => model_list_write <>= recursive subroutine model_list_write (object, unit, verbose, follow_link) class(model_list_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical, intent(in), optional :: follow_link type(model_entry_t), pointer :: current logical :: rec integer :: u u = given_output_unit (unit); if (u < 0) return rec = .true.; if (present (follow_link)) rec = follow_link if (rec .and. associated (object%context)) then call object%context%write (unit, verbose, follow_link) end if current => object%first if (associated (current)) then do while (associated (current)) call current%write (unit, verbose) current => current%next if (associated (current)) write (u, *) end do end if end subroutine model_list_write @ %def model_list_write @ Link this list to another one. <>= procedure :: link => model_list_link <>= subroutine model_list_link (model_list, context) class(model_list_t), intent(inout) :: model_list type(model_list_t), intent(in), target :: context model_list%context => context end subroutine model_list_link @ %def model_list_link @ (Private, used below:) Append an existing model, for which we have allocated a pointer entry, to the model list. The original pointer becomes disassociated, and the model should now be considered as part of the list. We assume that this model is not yet part of the list. If we provide a [[model]] argument, this returns a pointer to the new entry. <>= procedure, private :: import => model_list_import <>= subroutine model_list_import (model_list, current, model) class(model_list_t), intent(inout) :: model_list type(model_entry_t), pointer, intent(inout) :: current type(model_t), optional, pointer, intent(out) :: model if (associated (current)) then if (associated (model_list%first)) then model_list%last%next => current else model_list%first => current end if model_list%last => current if (present (model)) model => current%model_t current => null () end if end subroutine model_list_import @ %def model_list_import @ Currently test only: Add a new model with given [[name]] to the list, if it does not yet exist. If successful, return a pointer to the new model. <>= procedure :: add => model_list_add <>= subroutine model_list_add (model_list, & name, os_data, n_par, n_prt, n_vtx, model) class(model_list_t), intent(inout) :: model_list type(string_t), intent(in) :: name type(os_data_t), intent(in) :: os_data integer, intent(in) :: n_par, n_prt, n_vtx type(model_t), pointer :: model type(model_entry_t), pointer :: current if (model_list%model_exists (name, follow_link=.false.)) then model => null () else allocate (current) call current%init (name, var_str (""), os_data, & n_par, n_prt, n_vtx) call model_list%import (current, model) end if end subroutine model_list_add @ %def model_list_add @ Read a new model from file and add to the list, if it does not yet exist. Finalize the model by allocating the vertex table. Return a pointer to the new model. If unsuccessful, return the original pointer. The model is always inserted in the last link of a chain of model lists. This way, we avoid loading models twice from different contexts. When a model is modified, we should first allocate a local copy. <>= procedure :: read_model => model_list_read_model <>= subroutine model_list_read_model & (model_list, name, filename, os_data, model, & scheme, ufo, ufo_path, rebuild_mdl) class(model_list_t), intent(inout), target :: model_list type(string_t), intent(in) :: name, filename type(os_data_t), intent(in) :: os_data type(model_t), pointer, intent(inout) :: model type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical, intent(in), optional :: rebuild_mdl class(model_list_t), pointer :: global_model_list type(model_entry_t), pointer :: current logical :: exist if (.not. model_list%model_exists (name, & scheme, ufo, ufo_path, follow_link=.true.)) then allocate (current) call current%read (filename, os_data, exist, & scheme=scheme, ufo=ufo, ufo_path_requested=ufo_path, & rebuild_mdl=rebuild_mdl) if (.not. exist) return if (current%get_name () /= name) then call msg_fatal ("Model file '" // char (filename) // & "' contains model '" // char (current%get_name ()) // & "' instead of '" // char (name) // "'") call current%final (); deallocate (current) return end if global_model_list => model_list do while (associated (global_model_list%context)) global_model_list => global_model_list%context end do call global_model_list%import (current, model) else model => model_list%get_model_ptr (name, scheme, ufo, ufo_path) end if end subroutine model_list_read_model @ %def model_list_read_model @ Append a copy of an existing model to a model list. Optionally, return pointer to the new entry. <>= procedure :: append_copy => model_list_append_copy <>= subroutine model_list_append_copy (model_list, orig, model) class(model_list_t), intent(inout) :: model_list type(model_t), intent(in), target :: orig type(model_t), intent(out), pointer, optional :: model type(model_entry_t), pointer :: copy allocate (copy) call copy%init_instance (orig) call model_list%import (copy, model) end subroutine model_list_append_copy @ %def model_list_append_copy @ Check if a model exists by examining the list. Check recursively unless told otherwise. <>= procedure :: model_exists => model_list_model_exists <>= recursive function model_list_model_exists & (model_list, name, scheme, ufo, ufo_path, follow_link) result (exists) class(model_list_t), intent(in) :: model_list logical :: exists type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical, intent(in), optional :: follow_link type(model_entry_t), pointer :: current logical :: rec rec = .true.; if (present (follow_link)) rec = follow_link current => model_list%first do while (associated (current)) if (current%matches (name, scheme, ufo, ufo_path)) then exists = .true. return end if current => current%next end do if (rec .and. associated (model_list%context)) then exists = model_list%context%model_exists (name, & scheme, ufo, ufo_path, follow_link) else exists = .false. end if end function model_list_model_exists @ %def model_list_model_exists @ Return a pointer to a named model. Search recursively unless told otherwise. <>= procedure :: get_model_ptr => model_list_get_model_ptr <>= recursive function model_list_get_model_ptr & (model_list, name, scheme, ufo, ufo_path, follow_link) result (model) class(model_list_t), intent(in) :: model_list type(model_t), pointer :: model type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical, intent(in), optional :: follow_link type(model_entry_t), pointer :: current logical :: rec rec = .true.; if (present (follow_link)) rec = follow_link current => model_list%first do while (associated (current)) if (current%matches (name, scheme, ufo, ufo_path)) then model => current%model_t return end if current => current%next end do if (rec .and. associated (model_list%context)) then model => model_list%context%get_model_ptr (name, & scheme, ufo, ufo_path, follow_link) else model => null () end if end function model_list_get_model_ptr @ %def model_list_get_model_ptr @ Delete the list of models. No recursion. <>= procedure :: final => model_list_final <>= subroutine model_list_final (model_list) class(model_list_t), intent(inout) :: model_list type(model_entry_t), pointer :: current model_list%last => null () do while (associated (model_list%first)) current => model_list%first model_list%first => model_list%first%next call current%final () deallocate (current) end do end subroutine model_list_final @ %def model_list_final @ \subsection{Model instances} A model instance is a copy of a model object. The parameters are true copies. The particle data and the variable list pointers should point to the copy, so modifying the parameters has only a local effect. Hence, we build them up explicitly. The vertex array is also rebuilt, it contains particle pointers. Finally, the vertex hash table can be copied directly since it contains no pointers. The [[multiplicity]] entry depends on the association of the [[mass_data]] entry and therefore has to be set at the end. The instance must carry the [[target]] attribute. Parameters: the [[copy_parameter]] method essentially copies the parameter decorations (parse node, expression etc.). The current parameter values are part of the [[model_data_t]] base type and are copied afterwards via its [[copy_from]] method. Note: the parameter set is initialized for real parameters only. In order for the local model to be able to use the correct UFO model setup, UFO model information has to be transferred. <>= procedure :: init_instance => model_copy <>= subroutine model_copy (model, orig) class(model_t), intent(out), target :: model type(model_t), intent(in) :: orig integer :: n_par, n_prt, n_vtx integer :: i n_par = orig%get_n_real () n_prt = orig%get_n_field () n_vtx = orig%get_n_vtx () call model%basic_init (orig%get_name (), n_par, n_prt, n_vtx) if (allocated (orig%schemes)) then model%schemes = orig%schemes if (allocated (orig%selected_scheme)) then model%selected_scheme = orig%selected_scheme call model%set_scheme_num (orig%get_scheme_num ()) end if end if if (allocated (orig%slha_block)) then model%slha_block = orig%slha_block end if model%md5sum = orig%md5sum model%ufo_model = orig%ufo_model model%ufo_path = orig%ufo_path if (allocated (orig%par)) then do i = 1, n_par call model%copy_parameter (i, orig%par(i)) end do end if model%init_external_parameters => orig%init_external_parameters call model%model_data_t%copy_from (orig) model%max_par_name_length = orig%max_par_name_length call model%append_field_vars () end subroutine model_copy @ %def model_copy @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[models_ut.f90]]>>= <> module models_ut use unit_tests use models_uti <> <> contains <> end module models_ut @ %def models_ut @ <<[[models_uti.f90]]>>= <> module models_uti <> <> use file_utils, only: delete_file use physics_defs, only: SCALAR, SPINOR use os_interface use model_data use variables use models <> <> contains <> end module models_uti @ %def models_ut @ API: driver for the unit tests below. <>= public :: models_test <>= subroutine models_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine models_test @ %def models_tests @ \subsubsection{Construct a Model} Here, we construct a toy model explicitly without referring to a file. <>= call test (models_1, "models_1", & "construct model", & u, results) <>= public :: models_1 <>= subroutine models_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model type(string_t) :: model_name type(string_t) :: x_longname type(string_t), dimension(2) :: parname type(string_t), dimension(2) :: x_name type(string_t), dimension(1) :: x_anti type(string_t) :: x_tex_name, x_tex_anti type(string_t) :: y_longname type(string_t), dimension(2) :: y_name type(string_t) :: y_tex_name type(field_data_t), pointer :: field write (u, "(A)") "* Test output: models_1" write (u, "(A)") "* Purpose: create a model" write (u, *) model_name = "Test model" call model_list%add (model_name, os_data, 2, 2, 3, model) parname(1) = "mx" parname(2) = "coup" call model%set_parameter_constant (1, parname(1), 10._default) call model%set_parameter_constant (2, parname(2), 1.3_default) x_longname = "X_LEPTON" x_name(1) = "X" x_name(2) = "x" x_anti(1) = "Xbar" x_tex_name = "X^+" x_tex_anti = "X^-" field => model%get_field_ptr_by_index (1) call field%init (x_longname, 99) call field%set ( & .true., .false., .false., .false., .false., & name=x_name, anti=x_anti, tex_name=x_tex_name, tex_anti=x_tex_anti, & spin_type=SPINOR, isospin_type=-3, charge_type=2, & mass_data=model%get_par_data_ptr (parname(1))) y_longname = "Y_COLORON" y_name(1) = "Y" y_name(2) = "yc" y_tex_name = "Y^0" field => model%get_field_ptr_by_index (2) call field%init (y_longname, 97) call field%set ( & .false., .false., .true., .false., .false., & name=y_name, tex_name=y_tex_name, & spin_type=SCALAR, isospin_type=2, charge_type=1, color_type=8) call model%set_vertex (1, [99, 99, 99]) call model%set_vertex (2, [99, 99, 99, 99]) call model%set_vertex (3, [99, 97, 99]) call model_list%write (u) call model_list%final () write (u, *) write (u, "(A)") "* Test output end: models_1" end subroutine models_1 @ %def models_1 @ \subsubsection{Read a Model} Read a predefined model from file. <>= call test (models_2, "models_2", & "read model", & u, results) <>= public :: models_2 <>= subroutine models_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(var_list_t), pointer :: var_list type(model_t), pointer :: model write (u, "(A)") "* Test output: models_2" write (u, "(A)") "* Purpose: read a model from file" write (u, *) call syntax_model_file_init () call os_data%init () call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), & os_data, model) call model_list%write (u) write (u, *) write (u, "(A)") "* Variable list" write (u, *) var_list => model%get_var_list_ptr () call var_list%write (u) write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_2" end subroutine models_2 @ %def models_2 @ \subsubsection{Model Instance} Read a predefined model from file and create an instance. <>= call test (models_3, "models_3", & "model instance", & u, results) <>= public :: models_3 <>= subroutine models_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model type(var_list_t), pointer :: var_list type(model_t), pointer :: instance write (u, "(A)") "* Test output: models_3" write (u, "(A)") "* Purpose: create a model instance" write (u, *) call syntax_model_file_init () call os_data%init () call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), & os_data, model) allocate (instance) call instance%init_instance (model) call model%write (u) write (u, *) write (u, "(A)") "* Variable list" write (u, *) var_list => instance%get_var_list_ptr () call var_list%write (u) write (u, *) write (u, "(A)") "* Cleanup" call instance%final () deallocate (instance) call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_3" end subroutine models_3 @ %def models_test @ \subsubsection{Unstable and Polarized Particles} Read a predefined model from file and define decays and polarization. <>= call test (models_4, "models_4", & "handle decays and polarization", & u, results) <>= public :: models_4 <>= subroutine models_4 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model, model_instance character(32) :: md5sum write (u, "(A)") "* Test output: models_4" write (u, "(A)") "* Purpose: set and unset decays and polarization" write (u, *) call syntax_model_file_init () call os_data%init () write (u, "(A)") "* Read model from file" call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), & os_data, model) md5sum = model%get_parameters_md5sum () write (u, *) write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'" write (u, *) write (u, "(A)") "* Set particle decays and polarization" write (u, *) call model%set_unstable (25, [var_str ("dec1"), var_str ("dec2")]) call model%set_polarized (6) call model%set_unstable (-6, [var_str ("fdec")]) call model%write (u) md5sum = model%get_parameters_md5sum () write (u, *) write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'" write (u, *) write (u, "(A)") "* Create a model instance" allocate (model_instance) call model_instance%init_instance (model) write (u, *) write (u, "(A)") "* Revert particle decays and polarization" write (u, *) call model%set_stable (25) call model%set_unpolarized (6) call model%set_stable (-6) call model%write (u) md5sum = model%get_parameters_md5sum () write (u, *) write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'" write (u, *) write (u, "(A)") "* Show the model instance" write (u, *) call model_instance%write (u) md5sum = model_instance%get_parameters_md5sum () write (u, *) write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'" write (u, *) write (u, "(A)") "* Cleanup" call model_instance%final () deallocate (model_instance) call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_4" end subroutine models_4 @ %def models_4 @ \subsubsection{Model Variables} Read a predefined model from file and modify some parameters. Note that the MD5 sum is not modified by this. <>= call test (models_5, "models_5", & "handle parameters", & u, results) <>= public :: models_5 <>= subroutine models_5 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model, model_instance character(32) :: md5sum write (u, "(A)") "* Test output: models_5" write (u, "(A)") "* Purpose: access and modify model variables" write (u, *) call syntax_model_file_init () call os_data%init () write (u, "(A)") "* Read model from file" call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), & os_data, model) write (u, *) call model%write (u, & show_md5sum = .true., & show_variables = .true., & show_parameters = .true., & show_particles = .false., & show_vertices = .false.) write (u, *) write (u, "(A)") "* Check parameter status" write (u, *) write (u, "(1x,A,L1)") "xy exists = ", model%var_exists (var_str ("xx")) write (u, "(1x,A,L1)") "ff exists = ", model%var_exists (var_str ("ff")) write (u, "(1x,A,L1)") "mf exists = ", model%var_exists (var_str ("mf")) write (u, "(1x,A,L1)") "ff locked = ", model%var_is_locked (var_str ("ff")) write (u, "(1x,A,L1)") "mf locked = ", model%var_is_locked (var_str ("mf")) write (u, *) write (u, "(1x,A,F6.2)") "ff = ", model%get_rval (var_str ("ff")) write (u, "(1x,A,F6.2)") "mf = ", model%get_rval (var_str ("mf")) write (u, *) write (u, "(A)") "* Modify parameter" write (u, *) call model%set_real (var_str ("ff"), 1._default) call model%write (u, & show_md5sum = .true., & show_variables = .true., & show_parameters = .true., & show_particles = .false., & show_vertices = .false.) write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_5" end subroutine models_5 @ %def models_5 @ \subsubsection{Read model with disordered parameters} Read a model from file where the ordering of independent and derived parameters is non-canonical. <>= call test (models_6, "models_6", & "read model parameters", & u, results) <>= public :: models_6 <>= subroutine models_6 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(var_list_t), pointer :: var_list type(model_t), pointer :: model write (u, "(A)") "* Test output: models_6" write (u, "(A)") "* Purpose: read a model from file & &with non-canonical parameter ordering" write (u, *) open (newunit=um, file="Test6.mdl", status="replace", action="readwrite") write (um, "(A)") 'model "Test6"' write (um, "(A)") ' parameter a = 1.000000000000E+00' write (um, "(A)") ' derived b = 2 * a' write (um, "(A)") ' parameter c = 3.000000000000E+00' write (um, "(A)") ' unused d' rewind (um) do read (um, "(A)", end=1) buffer write (u, "(A)") trim (buffer) end do 1 continue close (um) call syntax_model_file_init () call os_data%init () call model_list%read_model (var_str ("Test6"), var_str ("Test6.mdl"), & os_data, model) write (u, *) write (u, "(A)") "* Variable list" write (u, *) var_list => model%get_var_list_ptr () call var_list%write (u) write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_6" end subroutine models_6 @ %def models_6 @ \subsubsection{Read model with schemes} Read a model from file which supports scheme selection in the parameter list. <>= call test (models_7, "models_7", & "handle schemes", & u, results) <>= public :: models_7 <>= subroutine models_7 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(var_list_t), pointer :: var_list type(model_t), pointer :: model write (u, "(A)") "* Test output: models_7" write (u, "(A)") "* Purpose: read a model from file & &with scheme selection" write (u, *) open (newunit=um, file="Test7.mdl", status="replace", action="readwrite") write (um, "(A)") 'model "Test7"' write (um, "(A)") ' schemes = "foo", "bar", "gee"' write (um, "(A)") '' write (um, "(A)") ' select scheme' write (um, "(A)") ' scheme "foo"' write (um, "(A)") ' parameter a = 1' write (um, "(A)") ' derived b = 2 * a' write (um, "(A)") ' scheme other' write (um, "(A)") ' parameter b = 4' write (um, "(A)") ' derived a = b / 2' write (um, "(A)") ' end select' write (um, "(A)") '' write (um, "(A)") ' parameter c = 3' write (um, "(A)") '' write (um, "(A)") ' select scheme' write (um, "(A)") ' scheme "foo", "gee"' write (um, "(A)") ' derived d = b + c' write (um, "(A)") ' scheme other' write (um, "(A)") ' unused d' write (um, "(A)") ' end select' rewind (um) do read (um, "(A)", end=1) buffer write (u, "(A)") trim (buffer) end do 1 continue close (um) call syntax_model_file_init () call os_data%init () write (u, *) write (u, "(A)") "* Model output, default scheme (= foo)" write (u, *) call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), & os_data, model) call model%write (u, show_md5sum=.false.) call show_var_list () call show_par_array () call model_list%final () write (u, *) write (u, "(A)") "* Model output, scheme foo" write (u, *) call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), & os_data, model, scheme = var_str ("foo")) call model%write (u, show_md5sum=.false.) call show_var_list () call show_par_array () call model_list%final () write (u, *) write (u, "(A)") "* Model output, scheme bar" write (u, *) call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), & os_data, model, scheme = var_str ("bar")) call model%write (u, show_md5sum=.false.) call show_var_list () call show_par_array () call model_list%final () write (u, *) write (u, "(A)") "* Model output, scheme gee" write (u, *) call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), & os_data, model, scheme = var_str ("gee")) call model%write (u, show_md5sum=.false.) call show_var_list () call show_par_array () write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_7" contains subroutine show_var_list () write (u, *) write (u, "(A)") "* Variable list" write (u, *) var_list => model%get_var_list_ptr () call var_list%write (u) end subroutine show_var_list subroutine show_par_array () real(default), dimension(:), allocatable :: par integer :: n write (u, *) write (u, "(A)") "* Parameter array" write (u, *) n = model%get_n_real () allocate (par (n)) call model%real_parameters_to_array (par) write (u, 1) par 1 format (1X,F6.3) end subroutine show_par_array end subroutine models_7 @ %def models_7 @ \subsubsection{Read and handle UFO model} Read a model from file which is considered as an UFO model. In fact, it is a mock model file which just follows our naming convention for UFO models. Compare this to an equivalent non-UFO model. <>= call test (models_8, "models_8", & "handle UFO-derived models", & u, results) <>= public :: models_8 <>= subroutine models_8 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(string_t) :: model_name type(model_t), pointer :: model write (u, "(A)") "* Test output: models_8" write (u, "(A)") "* Purpose: distinguish models marked as UFO-derived" write (u, *) call os_data%init () call show_model_list_status () model_name = "models_8_M" write (u, *) write (u, "(A)") "* Write WHIZARD model" write (u, *) open (newunit=um, file=char (model_name // ".mdl"), & status="replace", action="readwrite") write (um, "(A)") 'model "models_8_M"' write (um, "(A)") ' parameter a = 1' rewind (um) do read (um, "(A)", end=1) buffer write (u, "(A)") trim (buffer) end do 1 continue close (um) write (u, *) write (u, "(A)") "* Write UFO model" write (u, *) open (newunit=um, file=char (model_name // ".ufo.mdl"), & status="replace", action="readwrite") write (um, "(A)") 'model "models_8_M"' write (um, "(A)") ' parameter a = 2' rewind (um) do read (um, "(A)", end=2) buffer write (u, "(A)") trim (buffer) end do 2 continue close (um) call syntax_model_file_init () call os_data%init () write (u, *) write (u, "(A)") "* Read WHIZARD model" write (u, *) call model_list%read_model (model_name, model_name // ".mdl", & os_data, model) call model%write (u, show_md5sum=.false.) call show_model_list_status () write (u, *) write (u, "(A)") "* Read UFO model" write (u, *) call model_list%read_model (model_name, model_name // ".ufo.mdl", & os_data, model, ufo=.true., rebuild_mdl = .false.) call model%write (u, show_md5sum=.false.) call show_model_list_status () write (u, *) write (u, "(A)") "* Reload WHIZARD model" write (u, *) call model_list%read_model (model_name, model_name // ".mdl", & os_data, model) call model%write (u, show_md5sum=.false.) call show_model_list_status () write (u, *) write (u, "(A)") "* Reload UFO model" write (u, *) call model_list%read_model (model_name, model_name // ".ufo.mdl", & os_data, model, ufo=.true., rebuild_mdl = .false.) call model%write (u, show_md5sum=.false.) call show_model_list_status () write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_8" contains subroutine show_model_list_status () write (u, "(A)") "* Model list status" write (u, *) write (u, "(A,1x,L1)") "WHIZARD model exists =", & model_list%model_exists (model_name) write (u, "(A,1x,L1)") "UFO model exists =", & model_list%model_exists (model_name, ufo=.true.) end subroutine show_model_list_status end subroutine models_8 @ %def models_8 @ \subsubsection{Generate UFO model file} Generate the necessary [[.ufo.mdl]] file from source, calling OMega, and load the model. Note: There must not be another unit test which works with the same UFO model. The model file is deleted explicitly at the end of this test. <>= call test (models_9, "models_9", & "generate UFO-derived model file", & u, results) <>= public :: models_9 <>= subroutine models_9 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(string_t) :: model_name, model_file_name type(model_t), pointer :: model write (u, "(A)") "* Test output: models_9" write (u, "(A)") "* Purpose: enable the UFO Standard Model (test version)" write (u, *) call os_data%init () call syntax_model_file_init () os_data%whizard_modelpath_ufo = "../models/UFO" model_name = "SM" model_file_name = model_name // ".models_9" // ".ufo.mdl" write (u, "(A)") "* Generate and read UFO model" write (u, *) call delete_file (char (model_file_name)) call model_list%read_model (model_name, model_file_name, os_data, model, ufo=.true.) call model%write (u, show_md5sum=.false.) write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_9" end subroutine models_9 @ %def models_9 @ \subsubsection{Read model with schemes} Read a model from file which contains [[slha_entry]] qualifiers for parameters. <>= call test (models_10, "models_10", & "handle slha_entry option", & u, results) <>= public :: models_10 <>= subroutine models_10 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(var_list_t), pointer :: var_list type(model_t), pointer :: model type(string_t), dimension(:), allocatable :: slha_block_name integer :: i write (u, "(A)") "* Test output: models_10" write (u, "(A)") "* Purpose: read a model from file & &with slha_entry options" write (u, *) open (newunit=um, file="Test10.mdl", status="replace", action="readwrite") write (um, "(A)") 'model "Test10"' write (um, "(A)") ' parameter a = 1 slha_entry FOO 1' write (um, "(A)") ' parameter b = 4 slha_entry BAR 2 1' rewind (um) do read (um, "(A)", end=1) buffer write (u, "(A)") trim (buffer) end do 1 continue close (um) call syntax_model_file_init () call os_data%init () write (u, *) write (u, "(A)") "* Model output, default scheme (= foo)" write (u, *) call model_list%read_model (var_str ("Test10"), var_str ("Test10.mdl"), & os_data, model) call model%write (u, show_md5sum=.false.) write (u, *) write (u, "(A)") "* Check that model contains slha_entry options" write (u, *) write (u, "(A,1x,L1)") & "supports_custom_slha =", model%supports_custom_slha () write (u, *) write (u, "(A)") "custom_slha_blocks =" call model%get_custom_slha_blocks (slha_block_name) do i = 1, size (slha_block_name) write (u, "(1x,A)", advance="no") char (slha_block_name(i)) end do write (u, *) write (u, *) write (u, "(A)") "* Parameter lookup" write (u, *) call show_slha ("FOO", [1]) call show_slha ("FOO", [2]) call show_slha ("BAR", [2, 1]) call show_slha ("GEE", [3]) write (u, *) write (u, "(A)") "* Modify parameter via SLHA block interface" write (u, *) call model%slha_set_par (var_str ("FOO"), [1], 7._default) call show_slha ("FOO", [1]) write (u, *) write (u, "(A)") "* Show var list with modified parameter" write (u, *) call show_var_list () write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_10" contains subroutine show_slha (block_name, block_index) character(*), intent(in) :: block_name integer, dimension(:), intent(in) :: block_index class(modelpar_data_t), pointer :: par_data write (u, "(A,*(1x,I0))", advance="no") block_name, block_index write (u, "(' => ')", advance="no") call model%slha_lookup (var_str (block_name), block_index, par_data) if (associated (par_data)) then call par_data%write (u) write (u, *) else write (u, "('-')") end if end subroutine show_slha subroutine show_var_list () var_list => model%get_var_list_ptr () call var_list%write (u) end subroutine show_var_list end subroutine models_10 @ %def models_10 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The SUSY Les Houches Accord} The SUSY Les Houches Accord defines a standard interfaces for storing the physics data of SUSY models. Here, we provide the means for reading, storing, and writing such data. <<[[slha_interface.f90]]>>= <> module slha_interface <> <> use io_units use constants use string_utils, only: upper_case use system_defs, only: VERSION_STRING use system_defs, only: EOF use diagnostics use os_interface use ifiles use lexers use syntax_rules use parser use variables use models <> <> <> <> save contains <> <> end module slha_interface @ %def slha_interface @ \subsection{Preprocessor} SLHA is a mixed-format standard. It should be read in assuming free format (but line-oriented), but it has some fixed-format elements. To overcome this difficulty, we implement a preprocessing step which transforms the SLHA into a format that can be swallowed by our generic free-format lexer and parser. Each line with a blank first character is assumed to be a data line. We prepend a 'DATA' keyword to these lines. Furthermore, to enforce line-orientation, each line is appended a '\$' key which is recognized by the parser. To do this properly, we first remove trailing comments, and skip lines consisting only of comments. The preprocessor reads from a stream and puts out an [[ifile]]. Blocks that are not recognized are skipped. For some blocks, data items are quoted, so they can be read as strings if necessary. A name clash occurse if the block name is identical to a keyword. This can happen for custom SLHA models and files. In that case, we prepend an underscore, which will be silently suppressed where needed. <>= integer, parameter :: MODE_SKIP = 0, MODE_DATA = 1, MODE_INFO = 2 @ %def MODE_SKIP = 0, MODE_DATA = 1, MODE_INFO = 2 <>= subroutine slha_preprocess (stream, custom_block_name, ifile) type(stream_t), intent(inout), target :: stream type(string_t), dimension(:), intent(in) :: custom_block_name type(ifile_t), intent(out) :: ifile type(string_t) :: buffer, line, item integer :: iostat integer :: mode mode = MODE SCAN_FILE: do call stream_get_record (stream, buffer, iostat) select case (iostat) case (0) call split (buffer, line, "#") if (len_trim (line) == 0) cycle SCAN_FILE select case (char (extract (line, 1, 1))) case ("B", "b") call check_block_handling (line, custom_block_name, mode) call ifile_append (ifile, line // "$") case ("D", "d") mode = MODE_DATA call ifile_append (ifile, line // "$") case (" ") select case (mode) case (MODE_DATA) call ifile_append (ifile, "DATA" // line // "$") case (MODE_INFO) line = adjustl (line) call split (line, item, " ") call ifile_append (ifile, "INFO" // " " // item // " " & // '"' // trim (adjustl (line)) // '" $') end select case default call msg_message (char (line)) call msg_fatal ("SLHA: Incomprehensible line") end select case (EOF) exit SCAN_FILE case default call msg_fatal ("SLHA: I/O error occured while reading SLHA input") end select end do SCAN_FILE end subroutine slha_preprocess @ %def slha_preprocess @ Return the mode that we should treat this block with. We add the [[custom_block_name]] array to the set of supported blocks, which otherwise includes only hard-coded block names. Those custom blocks are data blocks. Unknown blocks will be skipped altogether. The standard does not specify their internal format at all, so we must not parse their content. If the name of a (custom) block clashes with a keyword of the SLHA syntax, we append an underscore to the block name, modifying the current line string. This should be silently suppressed when actually parsing block names. <>= subroutine check_block_handling (line, custom_block_name, mode) type(string_t), intent(inout) :: line type(string_t), dimension(:), intent(in) :: custom_block_name integer, intent(out) :: mode type(string_t) :: buffer, key, block_name integer :: i buffer = trim (line) call split (buffer, key, " ") buffer = adjustl (buffer) call split (buffer, block_name, " ") buffer = adjustl (buffer) block_name = trim (adjustl (upper_case (block_name))) select case (char (block_name)) case ("MODSEL", "MINPAR", "SMINPUTS") mode = MODE_DATA case ("MASS") mode = MODE_DATA case ("NMIX", "UMIX", "VMIX", "STOPMIX", "SBOTMIX", "STAUMIX") mode = MODE_DATA case ("NMHMIX", "NMAMIX", "NMNMIX", "NMSSMRUN") mode = MODE_DATA case ("ALPHA", "HMIX") mode = MODE_DATA case ("AU", "AD", "AE") mode = MODE_DATA case ("SPINFO", "DCINFO") mode = MODE_INFO case default mode = MODE_SKIP CHECK_CUSTOM_NAMES: do i = 1, size (custom_block_name) if (block_name == custom_block_name(i)) then mode = MODE_DATA call mangle_keywords (block_name) line = key // " " // block_name // " " // trim (buffer) exit CHECK_CUSTOM_NAMES end if end do CHECK_CUSTOM_NAMES end select end subroutine check_block_handling @ %def check_block_handling @ Append an underscore to specific block names: <>= subroutine mangle_keywords (name) type(string_t), intent(inout) :: name select case (char (name)) case ("BLOCK", "DATA", "INFO", "DECAY") name = name // "_" end select end subroutine mangle_keywords @ %def mangle_keywords @ Remove the underscore again: <>= subroutine demangle_keywords (name) type(string_t), intent(inout) :: name select case (char (name)) case ("BLOCK_", "DATA_", "INFO_", "DECAY_") name = extract (name, 1, len(name)-1) end select end subroutine demangle_keywords @ %def demangle_keywords @ \subsection{Lexer and syntax} <>= type(syntax_t), target :: syntax_slha @ %def syntax_slha <>= public :: syntax_slha_init <>= subroutine syntax_slha_init () type(ifile_t) :: ifile call define_slha_syntax (ifile) call syntax_init (syntax_slha, ifile) call ifile_final (ifile) end subroutine syntax_slha_init @ %def syntax_slha_init <>= public :: syntax_slha_final <>= subroutine syntax_slha_final () call syntax_final (syntax_slha) end subroutine syntax_slha_final @ %def syntax_slha_final <>= public :: syntax_slha_write <>= subroutine syntax_slha_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_slha, unit) end subroutine syntax_slha_write @ %def syntax_slha_write <>= subroutine define_slha_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ slha = chunk*") call ifile_append (ifile, "ALT chunk = block_def | decay_def") call ifile_append (ifile, "SEQ block_def = " & // "BLOCK blockgen '$' block_line*") call ifile_append (ifile, "ALT blockgen = block_spec | q_spec") call ifile_append (ifile, "KEY BLOCK") call ifile_append (ifile, "SEQ q_spec = QNUMBERS pdg_code") call ifile_append (ifile, "KEY QNUMBERS") call ifile_append (ifile, "SEQ block_spec = block_name qvalue?") call ifile_append (ifile, "IDE block_name") call ifile_append (ifile, "SEQ qvalue = qname '=' real") call ifile_append (ifile, "IDE qname") call ifile_append (ifile, "KEY '='") call ifile_append (ifile, "REA real") call ifile_append (ifile, "KEY '$'") call ifile_append (ifile, "ALT block_line = block_data | block_info") call ifile_append (ifile, "SEQ block_data = DATA data_line '$'") call ifile_append (ifile, "KEY DATA") call ifile_append (ifile, "SEQ data_line = data_item+") call ifile_append (ifile, "ALT data_item = signed_number | number") call ifile_append (ifile, "SEQ signed_number = sign number") call ifile_append (ifile, "ALT sign = '+' | '-'") call ifile_append (ifile, "ALT number = integer | real") call ifile_append (ifile, "INT integer") call ifile_append (ifile, "KEY '-'") call ifile_append (ifile, "KEY '+'") call ifile_append (ifile, "SEQ block_info = INFO info_line '$'") call ifile_append (ifile, "KEY INFO") call ifile_append (ifile, "SEQ info_line = integer string_literal") call ifile_append (ifile, "QUO string_literal = '""'...'""'") call ifile_append (ifile, "SEQ decay_def = " & // "DECAY decay_spec '$' decay_data*") call ifile_append (ifile, "KEY DECAY") call ifile_append (ifile, "SEQ decay_spec = pdg_code data_item") call ifile_append (ifile, "ALT pdg_code = signed_integer | integer") call ifile_append (ifile, "SEQ signed_integer = sign integer") call ifile_append (ifile, "SEQ decay_data = DATA decay_line '$'") call ifile_append (ifile, "SEQ decay_line = data_item integer pdg_code+") end subroutine define_slha_syntax @ %def define_slha_syntax @ The SLHA specification allows for string data items in certain places. Currently, we do not interpret them, but the strings, which are not quoted, must be parsed somehow. The hack for this problem is to allow essentially all characters as special characters, so the string can be read before it is discarded. <>= public :: lexer_init_slha <>= subroutine lexer_init_slha (lexer) type(lexer_t), intent(out) :: lexer call lexer_init (lexer, & comment_chars = "#", & quote_chars = '"', & quote_match = '"', & single_chars = "+-=$", & special_class = [ "" ], & keyword_list = syntax_get_keyword_list_ptr (syntax_slha), & upper_case_keywords = .true.) ! $ end subroutine lexer_init_slha @ %def lexer_init_slha @ \subsection{Interpreter} \subsubsection{Find blocks} From the parse tree, find the node that represents a particular block. If [[required]] is true, issue an error if not found. Since [[block_name]] is always invoked with capital letters, we have to capitalize [[pn_block_name]]. <>= function slha_get_block_ptr & (parse_tree, block_name, required) result (pn_block) type(parse_node_t), pointer :: pn_block type(parse_tree_t), intent(in) :: parse_tree type(string_t), intent(in) :: block_name type(string_t) :: block_def logical, intent(in) :: required type(parse_node_t), pointer :: pn_root, pn_block_spec, pn_block_name pn_root => parse_tree%get_root_ptr () pn_block => parse_node_get_sub_ptr (pn_root) do while (associated (pn_block)) select case (char (parse_node_get_rule_key (pn_block))) case ("block_def") pn_block_spec => parse_node_get_sub_ptr (pn_block, 2) pn_block_name => parse_node_get_sub_ptr (pn_block_spec) select case (char (pn_block_name%get_rule_key ())) case ("block_name") block_def = trim (adjustl (upper_case & (pn_block_name%get_string ()))) case ("QNUMBERS") block_def = "QNUMBERS" end select if (block_def == block_name) then return end if end select pn_block => parse_node_get_next_ptr (pn_block) end do if (required) then call msg_fatal ("SLHA: block '" // char (block_name) // "' not found") end if end function slha_get_block_ptr @ %def slha_get_blck_ptr @ Scan the file for the first/next DECAY block. <>= function slha_get_first_decay_ptr (parse_tree) result (pn_decay) type(parse_node_t), pointer :: pn_decay type(parse_tree_t), intent(in) :: parse_tree type(parse_node_t), pointer :: pn_root pn_root => parse_tree%get_root_ptr () pn_decay => parse_node_get_sub_ptr (pn_root) do while (associated (pn_decay)) select case (char (parse_node_get_rule_key (pn_decay))) case ("decay_def") return end select pn_decay => parse_node_get_next_ptr (pn_decay) end do end function slha_get_first_decay_ptr function slha_get_next_decay_ptr (pn_block) result (pn_decay) type(parse_node_t), pointer :: pn_decay type(parse_node_t), intent(in), target :: pn_block pn_decay => parse_node_get_next_ptr (pn_block) do while (associated (pn_decay)) select case (char (parse_node_get_rule_key (pn_decay))) case ("decay_def") return end select pn_decay => parse_node_get_next_ptr (pn_decay) end do end function slha_get_next_decay_ptr @ %def slha_get_next_decay_ptr @ \subsubsection{Extract and transfer data from blocks} Given the parse node of a block, find the parse node of a particular switch or data line. Return this node and the node of the data item following the integer code. <>= subroutine slha_find_index_ptr (pn_block, pn_data, pn_item, code) type(parse_node_t), intent(in), target :: pn_block type(parse_node_t), intent(out), pointer :: pn_data type(parse_node_t), intent(out), pointer :: pn_item integer, intent(in) :: code pn_data => parse_node_get_sub_ptr (pn_block, 4) call slha_next_index_ptr (pn_data, pn_item, code) end subroutine slha_find_index_ptr subroutine slha_find_index_pair_ptr (pn_block, pn_data, pn_item, code1, code2) type(parse_node_t), intent(in), target :: pn_block type(parse_node_t), intent(out), pointer :: pn_data type(parse_node_t), intent(out), pointer :: pn_item integer, intent(in) :: code1, code2 pn_data => parse_node_get_sub_ptr (pn_block, 4) call slha_next_index_pair_ptr (pn_data, pn_item, code1, code2) end subroutine slha_find_index_pair_ptr @ %def slha_find_index_ptr slha_find_index_pair_ptr @ Starting from the pointer to a data line, find a data line with the given integer code. <>= subroutine slha_next_index_ptr (pn_data, pn_item, code) type(parse_node_t), intent(inout), pointer :: pn_data integer, intent(in) :: code type(parse_node_t), intent(out), pointer :: pn_item type(parse_node_t), pointer :: pn_line, pn_code do while (associated (pn_data)) pn_line => parse_node_get_sub_ptr (pn_data, 2) pn_code => parse_node_get_sub_ptr (pn_line) select case (char (parse_node_get_rule_key (pn_code))) case ("integer") if (parse_node_get_integer (pn_code) == code) then pn_item => parse_node_get_next_ptr (pn_code) return end if end select pn_data => parse_node_get_next_ptr (pn_data) end do pn_item => null () end subroutine slha_next_index_ptr @ %def slha_next_index_ptr @ Starting from the pointer to a data line, find a data line with the given integer code pair. <>= subroutine slha_next_index_pair_ptr (pn_data, pn_item, code1, code2) type(parse_node_t), intent(inout), pointer :: pn_data integer, intent(in) :: code1, code2 type(parse_node_t), intent(out), pointer :: pn_item type(parse_node_t), pointer :: pn_line, pn_code1, pn_code2 do while (associated (pn_data)) pn_line => parse_node_get_sub_ptr (pn_data, 2) pn_code1 => parse_node_get_sub_ptr (pn_line) select case (char (parse_node_get_rule_key (pn_code1))) case ("integer") if (parse_node_get_integer (pn_code1) == code1) then pn_code2 => parse_node_get_next_ptr (pn_code1) if (associated (pn_code2)) then select case (char (parse_node_get_rule_key (pn_code2))) case ("integer") if (parse_node_get_integer (pn_code2) == code2) then pn_item => parse_node_get_next_ptr (pn_code2) return end if end select end if end if end select pn_data => parse_node_get_next_ptr (pn_data) end do pn_item => null () end subroutine slha_next_index_pair_ptr @ %def slha_next_index_pair_ptr @ \subsubsection{Handle info data} Return all strings with index [[i]]. The result is an allocated string array. Since we do not know the number of matching entries in advance, we build an intermediate list which is transferred to the final array and deleted before exiting. <>= subroutine retrieve_strings_in_block (pn_block, code, str_array) type(parse_node_t), intent(in), target :: pn_block integer, intent(in) :: code type(string_t), dimension(:), allocatable, intent(out) :: str_array type(parse_node_t), pointer :: pn_data, pn_item type :: str_entry_t type(string_t) :: str type(str_entry_t), pointer :: next => null () end type str_entry_t type(str_entry_t), pointer :: first => null () type(str_entry_t), pointer :: current => null () integer :: n n = 0 call slha_find_index_ptr (pn_block, pn_data, pn_item, code) if (associated (pn_item)) then n = n + 1 allocate (first) first%str = parse_node_get_string (pn_item) current => first do while (associated (pn_data)) pn_data => parse_node_get_next_ptr (pn_data) call slha_next_index_ptr (pn_data, pn_item, code) if (associated (pn_item)) then n = n + 1 allocate (current%next) current => current%next current%str = parse_node_get_string (pn_item) end if end do allocate (str_array (n)) n = 0 do while (associated (first)) n = n + 1 current => first str_array(n) = current%str first => first%next deallocate (current) end do else allocate (str_array (0)) end if end subroutine retrieve_strings_in_block @ %def retrieve_strings_in_block @ \subsubsection{Transfer data from SLHA to variables} Extract real parameter with index [[i]]. If it does not exist, retrieve it from the variable list, using the given name. <>= function get_parameter_in_block (pn_block, code, name, var_list) result (var) real(default) :: var type(parse_node_t), intent(in), target :: pn_block integer, intent(in) :: code type(string_t), intent(in) :: name type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_data, pn_item call slha_find_index_ptr (pn_block, pn_data, pn_item, code) if (associated (pn_item)) then var = get_real_parameter (pn_item) else var = var_list%get_rval (name) end if end function get_parameter_in_block @ %def get_parameter_in_block @ Extract a real data item with index [[i]]. If it does exist, set it in the variable list, using the given name. If the variable is not present in the variable list, ignore it. <>= subroutine set_data_item (pn_block, code, name, var_list) type(parse_node_t), intent(in), target :: pn_block integer, intent(in) :: code type(string_t), intent(in) :: name type(var_list_t), intent(inout), target :: var_list type(parse_node_t), pointer :: pn_data, pn_item call slha_find_index_ptr (pn_block, pn_data, pn_item, code) if (associated (pn_item)) then call var_list%set_real (name, get_real_parameter (pn_item), & is_known=.true., ignore=.true.) end if end subroutine set_data_item @ %def set_data_item @ Extract a real matrix element with index [[i,j]]. If it does exists, set it in the variable list, using the given name. If the variable is not present in the variable list, ignore it. <>= subroutine set_matrix_element (pn_block, code1, code2, name, var_list) type(parse_node_t), intent(in), target :: pn_block integer, intent(in) :: code1, code2 type(string_t), intent(in) :: name type(var_list_t), intent(inout), target :: var_list type(parse_node_t), pointer :: pn_data, pn_item call slha_find_index_pair_ptr (pn_block, pn_data, pn_item, code1, code2) if (associated (pn_item)) then call var_list%set_real (name, get_real_parameter (pn_item), & is_known=.true., ignore=.true.) end if end subroutine set_matrix_element @ %def set_matrix_element @ \subsubsection{Transfer data from variables to SLHA} Get a real/integer parameter with index [[i]] from the variable list and write it to the current output file. In the integer case, we account for the fact that the variable is type real. If it does not exist, do nothing. <>= subroutine write_integer_data_item (u, code, name, var_list, comment) integer, intent(in) :: u integer, intent(in) :: code type(string_t), intent(in) :: name type(var_list_t), intent(in) :: var_list character(*), intent(in) :: comment integer :: item if (var_list%contains (name)) then item = nint (var_list%get_rval (name)) call write_integer_parameter (u, code, item, comment) end if end subroutine write_integer_data_item subroutine write_real_data_item (u, code, name, var_list, comment) integer, intent(in) :: u integer, intent(in) :: code type(string_t), intent(in) :: name type(var_list_t), intent(in) :: var_list character(*), intent(in) :: comment real(default) :: item if (var_list%contains (name)) then item = var_list%get_rval (name) call write_real_parameter (u, code, item, comment) end if end subroutine write_real_data_item @ %def write_real_data_item @ Get a real data item with two integer indices from the variable list and write it to the current output file. If it does not exist, do nothing. <>= subroutine write_matrix_element (u, code1, code2, name, var_list, comment) integer, intent(in) :: u integer, intent(in) :: code1, code2 type(string_t), intent(in) :: name type(var_list_t), intent(in) :: var_list character(*), intent(in) :: comment real(default) :: item if (var_list%contains (name)) then item = var_list%get_rval (name) call write_real_matrix_element (u, code1, code2, item, comment) end if end subroutine write_matrix_element @ %def write_matrix_element @ \subsection{Auxiliary function} Write a block header. <>= subroutine write_block_header (u, name, comment) integer, intent(in) :: u character(*), intent(in) :: name, comment write (u, "(A,1x,A,3x,'#',1x,A)") "BLOCK", name, comment end subroutine write_block_header @ %def write_block_header @ Extract a real parameter that may be defined real or integer, signed or unsigned. <>= function get_real_parameter (pn_item) result (var) real(default) :: var type(parse_node_t), intent(in), target :: pn_item type(parse_node_t), pointer :: pn_sign, pn_var integer :: sign select case (char (parse_node_get_rule_key (pn_item))) case ("signed_number") pn_sign => parse_node_get_sub_ptr (pn_item) pn_var => parse_node_get_next_ptr (pn_sign) select case (char (parse_node_get_key (pn_sign))) case ("+"); sign = +1 case ("-"); sign = -1 end select case default sign = +1 pn_var => pn_item end select select case (char (parse_node_get_rule_key (pn_var))) case ("integer"); var = sign * parse_node_get_integer (pn_var) case ("real"); var = sign * parse_node_get_real (pn_var) end select end function get_real_parameter @ %def get_real_parameter @ Auxiliary: Extract an integer parameter that may be defined signed or unsigned. A real value is an error. <>= function get_integer_parameter (pn_item) result (var) integer :: var type(parse_node_t), intent(in), target :: pn_item type(parse_node_t), pointer :: pn_sign, pn_var integer :: sign select case (char (parse_node_get_rule_key (pn_item))) case ("signed_integer") pn_sign => parse_node_get_sub_ptr (pn_item) pn_var => parse_node_get_next_ptr (pn_sign) select case (char (parse_node_get_key (pn_sign))) case ("+"); sign = +1 case ("-"); sign = -1 end select case ("integer") sign = +1 pn_var => pn_item case default call parse_node_write (pn_var) call msg_error ("SLHA: Integer parameter expected") var = 0 return end select var = sign * parse_node_get_integer (pn_var) end function get_integer_parameter @ %def get_real_parameter @ Write an integer parameter with a single index directly to file, using the required output format. <>= subroutine write_integer_parameter (u, code, item, comment) integer, intent(in) :: u integer, intent(in) :: code integer, intent(in) :: item character(*), intent(in) :: comment 1 format (1x, I9, 3x, 3x, I9, 4x, 3x, '#', 1x, A) write (u, 1) code, item, comment end subroutine write_integer_parameter @ %def write_integer_parameter @ Write a real parameter with two indices directly to file, using the required output format. <>= subroutine write_real_parameter (u, code, item, comment) integer, intent(in) :: u integer, intent(in) :: code real(default), intent(in) :: item character(*), intent(in) :: comment 1 format (1x, I9, 3x, 1P, E16.8, 0P, 3x, '#', 1x, A) write (u, 1) code, item, comment end subroutine write_real_parameter @ %def write_real_parameter @ Write a real parameter with a single index directly to file, using the required output format. <>= subroutine write_real_matrix_element (u, code1, code2, item, comment) integer, intent(in) :: u integer, intent(in) :: code1, code2 real(default), intent(in) :: item character(*), intent(in) :: comment 1 format (1x, I2, 1x, I2, 3x, 1P, E16.8, 0P, 3x, '#', 1x, A) write (u, 1) code1, code2, item, comment end subroutine write_real_matrix_element @ %def write_real_matrix_element @ \subsubsection{The concrete SLHA interpreter} SLHA codes for particular physics models <>= integer, parameter :: MDL_MSSM = 0 integer, parameter :: MDL_NMSSM = 1 @ %def MDL_MSSM MDL_NMSSM @ Take the parse tree and extract relevant data. Select the correct model and store all data that is present in the appropriate variable list. Finally, update the variable record. We assume that if the model contains custom SLHA block names, we just have to scan those to get complete information. Block names could coincide with the SLHA standard block names, but we do not have to assume this. This will be the situation for an UFO-generated file. In particular, an UFO file should contain all expressions necessary for computing dependent parameters, so we can forget about the strict SLHA standard and its hard-coded conventions. If there are no custom SLHA block names, we should assume that the model is a standard SUSY model, and the parameters and hard-coded blocks can be read as specified by the original SLHA standard. There are hard-coded block names and parameter calculations. Public for use in unit test. <>= public :: slha_interpret_parse_tree <>= subroutine slha_interpret_parse_tree & (parse_tree, model, input, spectrum, decays) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model logical, intent(in) :: input, spectrum, decays logical :: errors integer :: mssm_type if (model%supports_custom_slha ()) then call slha_handle_custom_file (parse_tree, model) else call slha_handle_MODSEL (parse_tree, model, mssm_type) if (input) then call slha_handle_SMINPUTS (parse_tree, model) call slha_handle_MINPAR (parse_tree, model, mssm_type) end if if (spectrum) then call slha_handle_info_block (parse_tree, "SPINFO", errors) if (errors) return call slha_handle_MASS (parse_tree, model) call slha_handle_matrix_block (parse_tree, "NMIX", "mn_", 4, 4, model) call slha_handle_matrix_block (parse_tree, "NMNMIX", "mixn_", 5, 5, model) call slha_handle_matrix_block (parse_tree, "UMIX", "mu_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "VMIX", "mv_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "STOPMIX", "mt_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "SBOTMIX", "mb_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "STAUMIX", "ml_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "NMHMIX", "mixh0_", 3, 3, model) call slha_handle_matrix_block (parse_tree, "NMAMIX", "mixa0_", 2, 3, model) call slha_handle_ALPHA (parse_tree, model) call slha_handle_HMIX (parse_tree, model) call slha_handle_NMSSMRUN (parse_tree, model) call slha_handle_matrix_block (parse_tree, "AU", "Au_", 3, 3, model) call slha_handle_matrix_block (parse_tree, "AD", "Ad_", 3, 3, model) call slha_handle_matrix_block (parse_tree, "AE", "Ae_", 3, 3, model) end if end if if (decays) then call slha_handle_info_block (parse_tree, "DCINFO", errors) if (errors) return call slha_handle_decays (parse_tree, model) end if end subroutine slha_interpret_parse_tree @ %def slha_interpret_parse_tree @ \subsubsection{Info blocks} Handle the informational blocks SPINFO and DCINFO. The first two items are program name and version. Items with index 3 are warnings. Items with index 4 are errors. We reproduce these as WHIZARD warnings and errors. <>= subroutine slha_handle_info_block (parse_tree, block_name, errors) type(parse_tree_t), intent(in) :: parse_tree character(*), intent(in) :: block_name logical, intent(out) :: errors type(parse_node_t), pointer :: pn_block type(string_t), dimension(:), allocatable :: msg integer :: i pn_block => slha_get_block_ptr & (parse_tree, var_str (block_name), required=.true.) if (.not. associated (pn_block)) then call msg_error ("SLHA: Missing info block '" & // trim (block_name) // "'; ignored.") errors = .true. return end if select case (block_name) case ("SPINFO") call msg_message ("SLHA: SUSY spectrum program info:") case ("DCINFO") call msg_message ("SLHA: SUSY decay program info:") end select call retrieve_strings_in_block (pn_block, 1, msg) do i = 1, size (msg) call msg_message ("SLHA: " // char (msg(i))) end do call retrieve_strings_in_block (pn_block, 2, msg) do i = 1, size (msg) call msg_message ("SLHA: " // char (msg(i))) end do call retrieve_strings_in_block (pn_block, 3, msg) do i = 1, size (msg) call msg_warning ("SLHA: " // char (msg(i))) end do call retrieve_strings_in_block (pn_block, 4, msg) do i = 1, size (msg) call msg_error ("SLHA: " // char (msg(i))) end do errors = size (msg) > 0 end subroutine slha_handle_info_block @ %def slha_handle_info_block @ \subsubsection{MODSEL} Handle the overall model definition. Only certain models are recognized. The soft-breaking model templates that determine the set of input parameters. This block used to be required, but for generic UFO model support we should allow for its absence. In that case, [[mssm_type]] will be set to a negative value. If the block is present, the model must be one of the following, or parsing ends with an error. <>= integer, parameter :: MSSM_GENERIC = 0 integer, parameter :: MSSM_SUGRA = 1 integer, parameter :: MSSM_GMSB = 2 integer, parameter :: MSSM_AMSB = 3 @ %def MSSM_GENERIC MSSM_MSUGRA MSSM_GMSB MSSM_AMSB <>= subroutine slha_handle_MODSEL (parse_tree, model, mssm_type) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(in), target :: model integer, intent(out) :: mssm_type type(parse_node_t), pointer :: pn_block, pn_data, pn_item type(string_t) :: model_name pn_block => slha_get_block_ptr & (parse_tree, var_str ("MODSEL"), required=.false.) if (.not. associated (pn_block)) then mssm_type = -1 return end if call slha_find_index_ptr (pn_block, pn_data, pn_item, 1) if (associated (pn_item)) then mssm_type = get_integer_parameter (pn_item) else mssm_type = MSSM_GENERIC end if call slha_find_index_ptr (pn_block, pn_data, pn_item, 3) if (associated (pn_item)) then select case (parse_node_get_integer (pn_item)) case (MDL_MSSM); model_name = "MSSM" case (MDL_NMSSM); model_name = "NMSSM" case default call msg_fatal ("SLHA: unknown model code in MODSEL") return end select else model_name = "MSSM" end if call slha_find_index_ptr (pn_block, pn_data, pn_item, 4) if (associated (pn_item)) then call msg_fatal (" R-parity violation is currently not supported by WHIZARD.") end if call slha_find_index_ptr (pn_block, pn_data, pn_item, 5) if (associated (pn_item)) then call msg_fatal (" CP violation is currently not supported by WHIZARD.") end if select case (char (model_name)) case ("MSSM") select case (char (model%get_name ())) case ("MSSM","MSSM_CKM","MSSM_Grav","MSSM_Hgg") model_name = model%get_name () case default call msg_fatal ("Selected model '" & // char (model%get_name ()) // "' does not match model '" & // char (model_name) // "' in SLHA input file.") return end select case ("NMSSM") select case (char (model%get_name ())) case ("NMSSM","NMSSM_CKM","NMSSM_Hgg") model_name = model%get_name () case default call msg_fatal ("Selected model '" & // char (model%get_name ()) // "' does not match model '" & // char (model_name) // "' in SLHA input file.") return end select case default call msg_bug ("SLHA model name '" & // char (model_name) // "' not recognized.") return end select call msg_message ("SLHA: Initializing model '" // char (model_name) // "'") end subroutine slha_handle_MODSEL @ %def slha_handle_MODSEL @ Write a MODSEL block, based on the contents of the current model. <>= subroutine slha_write_MODSEL (u, model, mssm_type) integer, intent(in) :: u type(model_t), intent(in), target :: model integer, intent(out) :: mssm_type type(var_list_t), pointer :: var_list integer :: model_id type(string_t) :: mtype_string var_list => model%get_var_list_ptr () if (var_list%contains (var_str ("mtype"))) then mssm_type = nint (var_list%get_rval (var_str ("mtype"))) else call msg_error ("SLHA: parameter 'mtype' (SUSY breaking scheme) " & // "is unknown in current model, no SLHA output possible") mssm_type = -1 return end if call write_block_header (u, "MODSEL", "SUSY model selection") select case (mssm_type) case (0); mtype_string = "Generic MSSM" case (1); mtype_string = "SUGRA" case (2); mtype_string = "GMSB" case (3); mtype_string = "AMSB" case default mtype_string = "unknown" end select call write_integer_parameter (u, 1, mssm_type, & "SUSY-breaking scheme: " // char (mtype_string)) select case (char (model%get_name ())) case ("MSSM"); model_id = MDL_MSSM case ("NMSSM"); model_id = MDL_NMSSM case default model_id = 0 end select call write_integer_parameter (u, 3, model_id, & "SUSY model type: " // char (model%get_name ())) end subroutine slha_write_MODSEL @ %def slha_write_MODSEL @ \subsubsection{SMINPUTS} Read SM parameters and update the variable list accordingly. If a parameter is not defined in the block, we use the previous value from the model variable list. For the basic parameters we have to do a small recalculation, since SLHA uses the $G_F$-$\alpha$-$m_Z$ scheme, while \whizard\ derives them from $G_F$, $m_W$, and $m_Z$. <>= subroutine slha_handle_SMINPUTS (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block real(default) :: alpha_em_i, GF, alphas, mZ real(default) :: ee, vv, cw_sw, cw2, mW real(default) :: mb, mtop, mtau type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str ("SMINPUTS"), required=.true.) if (.not. (associated (pn_block))) return alpha_em_i = & get_parameter_in_block (pn_block, 1, var_str ("alpha_em_i"), var_list) GF = get_parameter_in_block (pn_block, 2, var_str ("GF"), var_list) alphas = & get_parameter_in_block (pn_block, 3, var_str ("alphas"), var_list) mZ = get_parameter_in_block (pn_block, 4, var_str ("mZ"), var_list) mb = get_parameter_in_block (pn_block, 5, var_str ("mb"), var_list) mtop = get_parameter_in_block (pn_block, 6, var_str ("mtop"), var_list) mtau = get_parameter_in_block (pn_block, 7, var_str ("mtau"), var_list) ee = sqrt (4 * pi / alpha_em_i) vv = 1 / sqrt (sqrt (2._default) * GF) cw_sw = ee * vv / (2 * mZ) if (2*cw_sw <= 1) then cw2 = (1 + sqrt (1 - 4 * cw_sw**2)) / 2 mW = mZ * sqrt (cw2) call var_list%set_real (var_str ("GF"), GF, .true.) call var_list%set_real (var_str ("mZ"), mZ, .true.) call var_list%set_real (var_str ("mW"), mW, .true.) call var_list%set_real (var_str ("mtau"), mtau, .true.) call var_list%set_real (var_str ("mb"), mb, .true.) call var_list%set_real (var_str ("mtop"), mtop, .true.) call var_list%set_real (var_str ("alphas"), alphas, .true.) else call msg_fatal ("SLHA: Unphysical SM parameter values") return end if end subroutine slha_handle_SMINPUTS @ %def slha_handle_SMINPUTS @ Write a SMINPUTS block. <>= subroutine slha_write_SMINPUTS (u, model) integer, intent(in) :: u type(model_t), intent(in), target :: model type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () call write_block_header (u, "SMINPUTS", "SM input parameters") call write_real_data_item (u, 1, var_str ("alpha_em_i"), var_list, & "Inverse electromagnetic coupling alpha (Z pole)") call write_real_data_item (u, 2, var_str ("GF"), var_list, & "Fermi constant") call write_real_data_item (u, 3, var_str ("alphas"), var_list, & "Strong coupling alpha_s (Z pole)") call write_real_data_item (u, 4, var_str ("mZ"), var_list, & "Z mass") call write_real_data_item (u, 5, var_str ("mb"), var_list, & "b running mass (at mb)") call write_real_data_item (u, 6, var_str ("mtop"), var_list, & "top mass") call write_real_data_item (u, 7, var_str ("mtau"), var_list, & "tau mass") end subroutine slha_write_SMINPUTS @ %def slha_write_SMINPUTS @ \subsubsection{MINPAR} The block of SUSY input parameters. They are accessible to WHIZARD, but they only get used when an external spectrum generator is invoked. The precise set of parameters depends on the type of SUSY breaking, which by itself is one of the parameters. <>= subroutine slha_handle_MINPAR (parse_tree, model, mssm_type) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model integer, intent(in) :: mssm_type type(var_list_t), pointer :: var_list type(parse_node_t), pointer :: pn_block var_list => model%get_var_list_ptr () call var_list%set_real & (var_str ("mtype"), real(mssm_type, default), is_known=.true.) pn_block => slha_get_block_ptr & (parse_tree, var_str ("MINPAR"), required=.true.) select case (mssm_type) case (MSSM_SUGRA) call set_data_item (pn_block, 1, var_str ("m_zero"), var_list) call set_data_item (pn_block, 2, var_str ("m_half"), var_list) call set_data_item (pn_block, 3, var_str ("tanb"), var_list) call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list) call set_data_item (pn_block, 5, var_str ("A0"), var_list) case (MSSM_GMSB) call set_data_item (pn_block, 1, var_str ("Lambda"), var_list) call set_data_item (pn_block, 2, var_str ("M_mes"), var_list) call set_data_item (pn_block, 3, var_str ("tanb"), var_list) call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list) call set_data_item (pn_block, 5, var_str ("N_5"), var_list) call set_data_item (pn_block, 6, var_str ("c_grav"), var_list) case (MSSM_AMSB) call set_data_item (pn_block, 1, var_str ("m_zero"), var_list) call set_data_item (pn_block, 2, var_str ("m_grav"), var_list) call set_data_item (pn_block, 3, var_str ("tanb"), var_list) call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list) case default call set_data_item (pn_block, 3, var_str ("tanb"), var_list) end select end subroutine slha_handle_MINPAR @ %def slha_handle_MINPAR @ Write a MINPAR block as appropriate for the current model type. <>= subroutine slha_write_MINPAR (u, model, mssm_type) integer, intent(in) :: u type(model_t), intent(in), target :: model integer, intent(in) :: mssm_type type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () call write_block_header (u, "MINPAR", "Basic SUSY input parameters") select case (mssm_type) case (MSSM_SUGRA) call write_real_data_item (u, 1, var_str ("m_zero"), var_list, & "Common scalar mass") call write_real_data_item (u, 2, var_str ("m_half"), var_list, & "Common gaugino mass") call write_real_data_item (u, 3, var_str ("tanb"), var_list, & "tan(beta)") call write_integer_data_item (u, 4, & var_str ("sgn_mu"), var_list, & "Sign of mu") call write_real_data_item (u, 5, var_str ("A0"), var_list, & "Common trilinear coupling") case (MSSM_GMSB) call write_real_data_item (u, 1, var_str ("Lambda"), var_list, & "Soft-breaking scale") call write_real_data_item (u, 2, var_str ("M_mes"), var_list, & "Messenger scale") call write_real_data_item (u, 3, var_str ("tanb"), var_list, & "tan(beta)") call write_integer_data_item (u, 4, & var_str ("sgn_mu"), var_list, & "Sign of mu") call write_integer_data_item (u, 5, var_str ("N_5"), var_list, & "Messenger index") call write_real_data_item (u, 6, var_str ("c_grav"), var_list, & "Gravitino mass factor") case (MSSM_AMSB) call write_real_data_item (u, 1, var_str ("m_zero"), var_list, & "Common scalar mass") call write_real_data_item (u, 2, var_str ("m_grav"), var_list, & "Gravitino mass") call write_real_data_item (u, 3, var_str ("tanb"), var_list, & "tan(beta)") call write_integer_data_item (u, 4, & var_str ("sgn_mu"), var_list, & "Sign of mu") case default call write_real_data_item (u, 3, var_str ("tanb"), var_list, & "tan(beta)") end select end subroutine slha_write_MINPAR @ %def slha_write_MINPAR @ \subsubsection{Mass spectrum} Set masses. Since the particles are identified by PDG code, read the line and try to set the appropriate particle mass in the current model. At the end, update parameters, just in case the $W$ or $Z$ mass was included. <>= subroutine slha_handle_MASS (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block, pn_data, pn_line, pn_code type(parse_node_t), pointer :: pn_mass integer :: pdg real(default) :: mass pn_block => slha_get_block_ptr & (parse_tree, var_str ("MASS"), required=.true.) if (.not. (associated (pn_block))) return pn_data => parse_node_get_sub_ptr (pn_block, 4) do while (associated (pn_data)) pn_line => parse_node_get_sub_ptr (pn_data, 2) pn_code => parse_node_get_sub_ptr (pn_line) if (associated (pn_code)) then pdg = get_integer_parameter (pn_code) pn_mass => parse_node_get_next_ptr (pn_code) if (associated (pn_mass)) then mass = get_real_parameter (pn_mass) call model%set_field_mass (pdg, mass) else call msg_error ("SLHA: Block MASS: Missing mass value") end if else call msg_error ("SLHA: Block MASS: Missing PDG code") end if pn_data => parse_node_get_next_ptr (pn_data) end do end subroutine slha_handle_MASS @ %def slha_handle_MASS @ \subsubsection{Widths} Set widths. For each DECAY block, extract the header, read the PDG code and width, and try to set the appropriate particle width in the current model. <>= subroutine slha_handle_decays (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_decay, pn_decay_spec, pn_code, pn_width integer :: pdg real(default) :: width pn_decay => slha_get_first_decay_ptr (parse_tree) do while (associated (pn_decay)) pn_decay_spec => parse_node_get_sub_ptr (pn_decay, 2) pn_code => parse_node_get_sub_ptr (pn_decay_spec) pdg = get_integer_parameter (pn_code) pn_width => parse_node_get_next_ptr (pn_code) width = get_real_parameter (pn_width) call model%set_field_width (pdg, width) pn_decay => slha_get_next_decay_ptr (pn_decay) end do end subroutine slha_handle_decays @ %def slha_handle_decays @ \subsubsection{Mixing matrices} Read mixing matrices. We can treat all matrices by a single procedure if we just know the block name, variable prefix, and matrix dimension. The matrix dimension must be less than 10. For the pseudoscalar Higgses in NMSSM-type models we need off-diagonal matrices, so we generalize the definition. <>= subroutine slha_handle_matrix_block & (parse_tree, block_name, var_prefix, dim1, dim2, model) type(parse_tree_t), intent(in) :: parse_tree character(*), intent(in) :: block_name, var_prefix integer, intent(in) :: dim1, dim2 type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block type(var_list_t), pointer :: var_list integer :: i, j character(len=len(var_prefix)+2) :: var_name var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str (block_name), required=.false.) if (.not. (associated (pn_block))) return do i = 1, dim1 do j = 1, dim2 write (var_name, "(A,I1,I1)") var_prefix, i, j call set_matrix_element (pn_block, i, j, var_str (var_name), var_list) end do end do end subroutine slha_handle_matrix_block @ %def slha_handle_matrix_block @ \subsubsection{Higgs data} Read the block ALPHA which holds just the Higgs mixing angle. <>= subroutine slha_handle_ALPHA (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block, pn_line, pn_data, pn_item type(var_list_t), pointer :: var_list real(default) :: al_h var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str ("ALPHA"), required=.false.) if (.not. (associated (pn_block))) return pn_data => parse_node_get_sub_ptr (pn_block, 4) pn_line => parse_node_get_sub_ptr (pn_data, 2) pn_item => parse_node_get_sub_ptr (pn_line) if (associated (pn_item)) then al_h = get_real_parameter (pn_item) call var_list%set_real (var_str ("al_h"), al_h, & is_known=.true., ignore=.true.) end if end subroutine slha_handle_ALPHA @ %def slha_handle_matrix_block @ Read the block HMIX for the Higgs mixing parameters <>= subroutine slha_handle_HMIX (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str ("HMIX"), required=.false.) if (.not. (associated (pn_block))) return call set_data_item (pn_block, 1, var_str ("mu_h"), var_list) call set_data_item (pn_block, 2, var_str ("tanb_h"), var_list) end subroutine slha_handle_HMIX @ %def slha_handle_HMIX @ Read the block NMSSMRUN for the specific NMSSM parameters <>= subroutine slha_handle_NMSSMRUN (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str ("NMSSMRUN"), required=.false.) if (.not. (associated (pn_block))) return call set_data_item (pn_block, 1, var_str ("ls"), var_list) call set_data_item (pn_block, 2, var_str ("ks"), var_list) call set_data_item (pn_block, 3, var_str ("a_ls"), var_list) call set_data_item (pn_block, 4, var_str ("a_ks"), var_list) call set_data_item (pn_block, 5, var_str ("nmu"), var_list) end subroutine slha_handle_NMSSMRUN @ %def slha_handle_NMSSMRUN @ \subsection{Parsing custom SLHA files} With the introduction of UFO models, we support custom files in generic SLHA format that reset model parameters. In contrast to strict SLHA files, the order and naming of blocks is arbitrary. We scan the complete file (i.e., preprocessed parse tree), parsing all blocks that contain data lines. For each data line, we identify index array and associated value. Then we set the model parameter that is associated with that block name and index array, if it exists. <>= subroutine slha_handle_custom_file (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_root, pn_block type(parse_node_t), pointer :: pn_block_spec, pn_block_name type(parse_node_t), pointer :: pn_data, pn_line, pn_code, pn_item type(string_t) :: block_name integer, dimension(:), allocatable :: block_index integer :: n_index, i real(default) :: value pn_root => parse_tree%get_root_ptr () pn_block => pn_root%get_sub_ptr () HANDLE_BLOCKS: do while (associated (pn_block)) select case (char (pn_block%get_rule_key ())) case ("block_def") call slha_handle_custom_block (pn_block, model) end select pn_block => pn_block%get_next_ptr () end do HANDLE_BLOCKS end subroutine slha_handle_custom_file @ %def slha_handle_custom_file @ <>= subroutine slha_handle_custom_block (pn_block, model) type(parse_node_t), intent(in), target :: pn_block type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block_spec, pn_block_name type(parse_node_t), pointer :: pn_data, pn_line, pn_code, pn_item type(string_t) :: block_name integer, dimension(:), allocatable :: block_index integer :: n_index, i real(default) :: value pn_block_spec => parse_node_get_sub_ptr (pn_block, 2) pn_block_name => parse_node_get_sub_ptr (pn_block_spec) select case (char (parse_node_get_rule_key (pn_block_name))) case ("block_name") block_name = trim (adjustl (upper_case (pn_block_name%get_string ()))) case ("QNUMBERS") block_name = "QNUMBERS" end select call demangle_keywords (block_name) pn_data => pn_block%get_sub_ptr (4) HANDLE_LINES: do while (associated (pn_data)) select case (char (pn_data%get_rule_key ())) case ("block_data") pn_line => pn_data%get_sub_ptr (2) n_index = pn_line%get_n_sub () - 1 allocate (block_index (n_index)) pn_code => pn_line%get_sub_ptr () READ_LINE: do i = 1, n_index select case (char (pn_code%get_rule_key ())) case ("integer"); block_index(i) = pn_code%get_integer () case default pn_code => null () exit READ_LINE end select pn_code => pn_code%get_next_ptr () end do READ_LINE if (associated (pn_code)) then value = get_real_parameter (pn_code) call model%slha_set_par (block_name, block_index, value) end if deallocate (block_index) end select pn_data => pn_data%get_next_ptr () end do HANDLE_LINES end subroutine slha_handle_custom_block @ %def slha_handle_custom_block @ \subsection{Parser} Read a SLHA file from stream, including preprocessing, and make up a parse tree. <>= subroutine slha_parse_stream (stream, custom_block_name, parse_tree) type(stream_t), intent(inout), target :: stream type(string_t), dimension(:), intent(in) :: custom_block_name type(parse_tree_t), intent(out) :: parse_tree type(ifile_t) :: ifile type(lexer_t) :: lexer type(stream_t), target :: stream_tmp call slha_preprocess (stream, custom_block_name, ifile) call stream_init (stream_tmp, ifile) call lexer_init_slha (lexer) call lexer_assign_stream (lexer, stream_tmp) call parse_tree_init (parse_tree, syntax_slha, lexer) call lexer_final (lexer) call stream_final (stream_tmp) call ifile_final (ifile) end subroutine slha_parse_stream @ %def slha_parse_stream @ Read a SLHA file chosen by name. Check first the current directory, then the directory where SUSY input files should be located. The [[default_mode]] applies to unknown blocks in the SLHA file: this is either [[MODE_SKIP]] or [[MODE_DATA]], corresponding to genuine SUSY and custom file content, respectively. <>= public :: slha_parse_file <>= subroutine slha_parse_file (file, custom_block_name, os_data, parse_tree) type(string_t), intent(in) :: file type(string_t), dimension(:), intent(in) :: custom_block_name type(os_data_t), intent(in) :: os_data type(parse_tree_t), intent(out) :: parse_tree logical :: exist type(string_t) :: filename type(stream_t), target :: stream call msg_message ("Reading SLHA input file '" // char (file) // "'") filename = file inquire (file=char(filename), exist=exist) if (.not. exist) then filename = os_data%whizard_susypath // "/" // file inquire (file=char(filename), exist=exist) if (.not. exist) then call msg_fatal ("SLHA input file '" // char (file) // "' not found") return end if end if call stream_init (stream, char (filename)) call slha_parse_stream (stream, custom_block_name, parse_tree) call stream_final (stream) end subroutine slha_parse_file @ %def slha_parse_file @ \subsection{API} Read the SLHA file, parse it, and interpret the parse tree. The model parameters retrieved from the file will be inserted into the appropriate model, which is loaded and modified in the background. The pointer to this model is returned as the last argument. <>= public :: slha_read_file <>= subroutine slha_read_file & (file, os_data, model, input, spectrum, decays) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data type(model_t), intent(inout), target :: model logical, intent(in) :: input, spectrum, decays type(string_t), dimension(:), allocatable :: custom_block_name type(parse_tree_t) :: parse_tree call model%get_custom_slha_blocks (custom_block_name) call slha_parse_file (file, custom_block_name, os_data, parse_tree) if (associated (parse_tree%get_root_ptr ())) then call slha_interpret_parse_tree & (parse_tree, model, input, spectrum, decays) call parse_tree_final (parse_tree) call model%update_parameters () end if end subroutine slha_read_file @ %def slha_read_file @ Write the SLHA contents, as far as possible, to external file. <>= public :: slha_write_file <>= subroutine slha_write_file (file, model, input, spectrum, decays) type(string_t), intent(in) :: file type(model_t), target, intent(in) :: model logical, intent(in) :: input, spectrum, decays integer :: mssm_type integer :: u u = free_unit () call msg_message ("Writing SLHA output file '" // char (file) // "'") open (unit=u, file=char(file), action="write", status="replace") write (u, "(A)") "# SUSY Les Houches Accord" write (u, "(A)") "# Output generated by " // trim (VERSION_STRING) call slha_write_MODSEL (u, model, mssm_type) if (input) then call slha_write_SMINPUTS (u, model) call slha_write_MINPAR (u, model, mssm_type) end if if (spectrum) then call msg_bug ("SLHA: spectrum output not supported yet") end if if (decays) then call msg_bug ("SLHA: decays output not supported yet") end if close (u) end subroutine slha_write_file @ %def slha_write_file @ \subsection{Dispatch} <>= public :: dispatch_slha <>= subroutine dispatch_slha (var_list, input, spectrum, decays) type(var_list_t), intent(inout), target :: var_list logical, intent(out) :: input, spectrum, decays input = var_list%get_lval (var_str ("?slha_read_input")) spectrum = var_list%get_lval (var_str ("?slha_read_spectrum")) decays = var_list%get_lval (var_str ("?slha_read_decays")) end subroutine dispatch_slha @ %def dispatch_slha @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[slha_interface_ut.f90]]>>= <> module slha_interface_ut use unit_tests use slha_interface_uti <> <> contains <> end module slha_interface_ut @ %def slha_interface_ut @ <<[[slha_interface_uti.f90]]>>= <> module slha_interface_uti <> use io_units use os_interface use parser use model_data use variables use models use slha_interface <> <> contains <> end module slha_interface_uti @ %def slha_interface_ut @ API: driver for the unit tests below. <>= public :: slha_test <>= subroutine slha_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine slha_test @ %def slha_test @ Checking the basics of the SLHA interface. <>= call test (slha_1, "slha_1", & "check SLHA interface", & u, results) <>= public :: slha_1 <>= subroutine slha_1 (u) integer, intent(in) :: u type(os_data_t), pointer :: os_data => null () type(parse_tree_t), pointer :: parse_tree => null () integer :: u_file, iostat character(80) :: buffer character(*), parameter :: file_slha = "slha_test.dat" type(model_list_t) :: model_list type(model_t), pointer :: model => null () type(string_t), dimension(0) :: empty_string_array write (u, "(A)") "* Test output: SLHA Interface" write (u, "(A)") "* Purpose: test SLHA file reading and writing" write (u, "(A)") write (u, "(A)") "* Initializing" write (u, "(A)") allocate (os_data) allocate (parse_tree) call os_data%init () call syntax_model_file_init () call model_list%read_model & (var_str("MSSM"), var_str("MSSM.mdl"), os_data, model) call syntax_slha_init () write (u, "(A)") "* Reading SLHA file sps1ap_decays.slha" write (u, "(A)") call slha_parse_file (var_str ("sps1ap_decays.slha"), & empty_string_array, os_data, parse_tree) write (u, "(A)") "* Writing the parse tree:" write (u, "(A)") call parse_tree_write (parse_tree, u) write (u, "(A)") "* Interpreting the parse tree" write (u, "(A)") call slha_interpret_parse_tree (parse_tree, model, & input=.true., spectrum=.true., decays=.true.) call parse_tree_final (parse_tree) write (u, "(A)") "* Writing out the list of variables (reals only):" write (u, "(A)") call var_list_write (model%get_var_list_ptr (), & only_type = V_REAL, unit = u) write (u, "(A)") write (u, "(A)") "* Writing SLHA output to '" // file_slha // "'" write (u, "(A)") call slha_write_file (var_str (file_slha), model, input=.true., & spectrum=.false., decays=.false.) u_file = free_unit () open (u_file, file = file_slha, action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:37) == "# Output generated by WHIZARD version") then buffer = "[...]" end if if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call parse_tree_final (parse_tree) deallocate (parse_tree) deallocate (os_data) write (u, "(A)") "* Test output end: slha_1" write (u, "(A)") end subroutine slha_1 @ %def slha_1 @ \subsubsection{SLHA interface} This rather trivial sets all input values for the SLHA interface to [[false]]. <>= call test (slha_2, "slha_2", & "SLHA interface", & u, results) <>= public :: slha_2 <>= subroutine slha_2 (u) integer, intent(in) :: u type(var_list_t) :: var_list logical :: input, spectrum, decays write (u, "(A)") "* Test output: slha_2" write (u, "(A)") "* Purpose: SLHA interface settings" write (u, "(A)") write (u, "(A)") "* Default settings" write (u, "(A)") call var_list%init_defaults (0) call dispatch_slha (var_list, & input = input, spectrum = spectrum, decays = decays) write (u, "(A,1x,L1)") " slha_read_input =", input write (u, "(A,1x,L1)") " slha_read_spectrum =", spectrum write (u, "(A,1x,L1)") " slha_read_decays =", decays call var_list%final () call var_list%init_defaults (0) write (u, "(A)") write (u, "(A)") "* Set all entries to [false]" write (u, "(A)") call var_list%set_log (var_str ("?slha_read_input"), & .false., is_known = .true.) call var_list%set_log (var_str ("?slha_read_spectrum"), & .false., is_known = .true.) call var_list%set_log (var_str ("?slha_read_decays"), & .false., is_known = .true.) call dispatch_slha (var_list, & input = input, spectrum = spectrum, decays = decays) write (u, "(A,1x,L1)") " slha_read_input =", input write (u, "(A,1x,L1)") " slha_read_spectrum =", spectrum write (u, "(A,1x,L1)") " slha_read_decays =", decays call var_list%final () write (u, "(A)") write (u, "(A)") "* Test output end: slha_2" end subroutine slha_2 @ %def slha_2