Index: trunk/ChangeLog =================================================================== --- trunk/ChangeLog (revision 8345) +++ trunk/ChangeLog (revision 8346) @@ -1,1949 +1,1953 @@ ChangeLog -- Summary of changes to the WHIZARD package Use svn log to see detailed changes. Version 2.8.3 2020-01-09 RELEASE: version 2.8.3 +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 Bugfix for process libraries in shower resonance histories 2017-09-21 Correctly generate pT distribution for EPA remnants 2017-09-20 Set branching ratios for unstable particles also by hand 2017-09-14 Correctly generate pT distribution for ISR photons ################################################################## 2017-09-08 RELEASE: version 2.6.0 2017-09-05 Bug fix for initial state NLO QCD flavor structures Real and virtual NLO QCD hadron collider processes work with internal interactions 2017-09-04 Fully validated MPI integration and event generation 2017-09-01 Resonance histories for shower: full support Bug fix in O'Mega model constraints O'Mega allows to output a parsable form of the DAG 2017-08-24 Resonance histories in events for transferral to parton shower (e.g. in ee -> jjjj) 2017-08-01 Alpha version of HepMC v3 interface (not yet really functional) 2017-07-31 Beta version for RECOLA OLP support 2017-07-06 Radiation generator fix for LHC processes 2017-06-30 Fix bug for NLO with structure functions and/or polarization 2017-06-23 Collinear limit for QED corrections works 2017-06-17 POWHEG grids generated already during integration 2017-06-12 Soft limit for QED corrections works 2017-05-16 Beta version of full MPI parallelization (VAMP2) Check consistency of POWHEG grid files Logfile config-summary.log for configure summary 2017-05-12 Allow polarization in top threshold 2017-05-09 Minimal demand automake 1.12.2 Silent rules for make procedures 2017-05-07 Major fix for POWHEG damping Correctly initialize FKS ISR phasespace ################################################################## 2017-05-06 RELEASE: version 2.5.0 2017-05-05 Full UFO support (SM-like models) Fixed-beam ISR FKS phase space 2017-04-26 QED splittings in radiation generator 2017-04-10 Retire deprecated O'Mega vertex cache files ################################################################## 2017-03-24 RELEASE: version 2.4.1 2017-03-16 Distinguish resonance charge in phase space channels Keep track of resonance histories in phase space Complex mass scheme default for OpenLoops amplitudes 2017-03-13 Fix helicities for polarized OpenLoops calculations 2017-03-09 Possibility to advance RNG state in rng_stream 2017-03-04 General setup for partitioning real emission phase space 2017-03-06 Bugfix on rescan command for converting event files 2017-02-27 Alternative multi-channel VEGAS implementation VAMP2: serial backbone for MPI setup Smoothstep top threshold matching 2017-02-25 Single-beam structure function with s-channel mapping supported Safeguard against invalid process libraries 2017-02-16 Radiation generator for photon emission 2017-02-10 Fixes for NLO QCD processes (color correlations) 2017-01-16 LCIO variable takes precedence over LCIO_DIR 2017-01-13 Alternative random number generator rng_stream (cf. L'Ecuyer et al.) 2017-01-01 Fix for multi-flavor BLHA tree matrix elements 2016-12-31 Grid path option for VAMP grids 2016-12-28 Alpha version of Recola OLP support 2016-12-27 Dalitz plots for FKS phase space 2016-12-14 NLO multi-flavor events possible 2016-12-09 LCIO event header information added 2016-12-02 Alpha version of RECOLA interface Bugfix for generator status in LCIO ################################################################## 2016-11-28 RELEASE: version 2.4.0 2016-11-24 Bugfix for OpenLoops interface: EW scheme is set by WHIZARD Bugfixes for top threshold implementation 2016-11-11 Refactoring of dispatching 2016-10-18 Bug fix for LCIO output 2016-10-10 First implementation for collinear soft terms 2016-10-06 First full WHIZARD models from UFO files 2016-10-05 WHIZARD does not support legacy gcc 4.7.4 any longer 2016-09-30 Major refactoring of process core and NLO components 2016-09-23 WHIZARD homogeneous entity: discarding subconfigures for CIRCE1/2, O'Mega, VAMP subpackages; these are reconstructable by script projectors 2016-09-06 Introduce main configure summary 2016-08-26 Fix memory leak in event generation ################################################################## 2016-08-25 RELEASE: version 2.3.1 2016-08-19 Bug fix for EW-scheme dependence of gluino propagators 2016-08-01 Beta version of complex mass scheme support 2016-07-26 Fix bug in POWHEG damping for the matching ################################################################## 2016-07-21 RELEASE: version 2.3.0 2016-07-20 UFO file support (alpha version) in O'Mega 2016-07-13 New (more) stable of WHIZARD GUI Support for EW schemes for OpenLoops Factorized NLO top decays for threshold model 2016-06-15 Passing factorization scale to PYTHIA6 Adding charge and neutral observables 2016-06-14 Correcting angular distribution/tweaked kinematics in non-collinear structure functions splittings 2016-05-10 Include (Fortran) TAUOLA/PHOTOS for tau decays via PYTHIA6 (backwards validation of LC CDR/TDR samples) 2016-04-27 Within OpenLoops virtuals: support for Collier library 2016-04-25 O'Mega vertex tables only loaded at first usage 2016-04-21 New CJ15 PDF parameterizations added 2016-04-21 Support for hadron collisions at NLO QCD 2016-04-05 Support for different (parameter) schemes in model files 2016-03-31 Correct transferral of lifetime/vertex from PYTHIA/TAUOLA into the event record 2016-03-21 New internal implementation of polarization via Bloch vectors, remove pointer constructions 2016-03-13 Extension of cascade syntax for processes: exclude propagators/vertices etc. possible 2016-02-24 Full support for OpenLoops QCD NLO matrix elements, inclusion in test suite 2016-02-12 Substantial progress on QCD NLO support 2016-02-02 Automated resonance mapping for FKS subtraction 2015-12-17 New BSM model WZW for diphoton resonances ################################################################## 2015-11-22 RELEASE: version 2.2.8 2015-11-21 Bugfix for fixed-order NLO events 2015-11-20 Anomalous FCNC top-charm vertices 2015-11-19 StdHEP output via HEPEVT/HEPEV4 supported 2015-11-18 Full set of electroweak dim-6 operators included 2015-10-22 Polarized one-loop amplitudes supported 2015-10-21 Fixes for event formats for showered events 2015-10-14 Callback mechanism for event output 2015-09-22 Bypass matrix elements in pure event sample rescans StdHep frozen final version v5.06.01 included internally 2015-09-21 configure option --with-precision to demand 64bit, 80bit, or 128bit Fortran and bind C precision types 2015-09-07 More extensive tests of NLO infrastructure and POWHEG matching 2015-09-01 NLO decay infrastructure User-defined squared matrix elements Inclusive FastJet algorithm plugin Numerical improvement for small boosts ################################################################## 2015-08-11 RELEASE: version 2.2.7 2015-08-10 Infrastructure for damped POWHEG Massive emitters in POWHEG Born matrix elements via BLHA GoSam filters via SINDARIN Minor running coupling bug fixes Fixed-order NLO events 2015-08-06 CT14 PDFs included (LO, NLO, NNLL) 2015-07-07 Revalidation of ILC WHIZARD-PYTHIA event chain Extended test suite for showered events Alpha version of massive FSR for POWHEG 2015-06-09 Fix memory leak in interaction for long cascades Catch mismatch between beam definition and CIRCE2 spectrum 2015-06-08 Automated POWHEG matching: beta version Infrastructure for GKS matching Alpha version of fixed-order NLO events CIRCE2 polarization averaged spectra with explicitly polarized beams 2015-05-12 Abstract matching type: OO structure for matching/merging 2015-05-07 Bug fix in event record WHIZARD-PYTHIA6 transferral Gaussian beam spectra for lepton colliders ################################################################## 2015-05-02 RELEASE: version 2.2.6 2015-05-01 Models for (unitarized) tensor resonances in VBS 2015-04-28 Bug fix in channel weights for event generation. 2015-04-18 Improved event record transfer WHIZARD/PYTHIA6 2015-03-19 POWHEG matching: alpha version ################################################################## 2015-02-27 RELEASE: version 2.2.5 2015-02-26 Abstract types for quantum numbers 2015-02-25 Read-in of StdHEP events, self-tests 2015-02-22 Bugfix for mother-daughter relations in showered/hadronized events 2015-02-20 Projection on polarization in intermediate states 2015-02-13 Correct treatment of beam remnants in event formats (also LC remnants) ################################################################## 2015-02-06 RELEASE: version 2.2.4 2015-02-06 Bugfix in event output 2015-02-05 LCIO event format supported 2015-01-30 Including state matrices in WHIZARD's internal IO Versioning for WHIZARD's internal IO Libtool update from 2.4.3 to 2.4.5 LCIO event output (beta version) 2015-01-27 Progress on NLO integration Fixing a bug for multiple processes in a single event file when using beam event files 2015-01-19 Bug fix for spin correlations evaluated in the rest frame of the mother particle 2015-01-17 Regression fix for statically linked processes from SARAH and FeynRules 2015-01-10 NLO: massive FKS emitters supported (experimental) 2015-01-06 MMHT2014 PDF sets included 2015-01-05 Handling mass degeneracies in auto_decays 2014-12-19 Fixing bug in rescan of event files ################################################################## 2014-11-30 RELEASE: version 2.2.3 2014-11-29 Beta version of LO continuum/NLL-threshold matched top threshold model for e+e- physics 2014-11-28 More internal refactoring: disentanglement of module dependencies 2014-11-21 OVM: O'Mega Virtual Machine, bytecode instructions instead of compiled Fortran code 2014-11-01 Higgs Singlet extension model included 2014-10-18 Internal restructuring of code; half-way WHIZARD main code file disassembled 2014-07-09 Alpha version of NLO infrastructure ################################################################## 2014-07-06 RELEASE: version 2.2.2 2014-07-05 CIRCE2: correlated LC beam spectra and GuineaPig Interface to LC machine parameters 2014-07-01 Reading LHEF for decayed/factorized/showered/ hadronized events 2014-06-25 Configure support for GoSAM/Ninja/Form/QGraf 2014-06-22 LHAPDF6 interface 2014-06-18 Module for automatic generation of radiation and loop infrastructure code 2014-06-11 Improved internal directory structure ################################################################## 2014-06-03 RELEASE: version 2.2.1 2014-05-30 Extensions of internal PDG arrays 2014-05-26 FastJet interface 2014-05-24 CJ12 PDFs included 2014-05-20 Regression fix for external models (via SARAH or FeynRules) ################################################################## 2014-05-18 RELEASE: version 2.2.0 2014-04-11 Multiple components: inclusive process definitions, syntax: process A + B + ... 2014-03-13 Improved PS mappings for e+e- ISR ILC TDR and CLIC spectra included in CIRCE1 2014-02-23 New models: AltH w\ Higgs for exclusion purposes, SM_rx for Dim 6-/Dim-8 operators, SSC for general strong interactions (w/ Higgs), and NoH_rx (w\ Higgs) 2014-02-14 Improved s-channel mapping, new on-shell production mapping (e.g. Drell-Yan) 2014-02-03 PRE-RELEASE: version 2.2.0_beta 2014-01-26 O'Mega: Feynman diagram generation possible (again) 2013-12-16 HOPPET interface for b parton matching 2013-11-15 PRE-RELEASE: version 2.2.0_alpha-4 2013-10-27 LHEF standards 1.0/2.0/3.0 implemented 2013-10-15 PRE-RELEASE: version 2.2.0_alpha-3 2013-10-02 PRE-RELEASE: version 2.2.0_alpha-2 2013-09-25 PRE-RELEASE: version 2.2.0_alpha-1 2013-09-12 PRE-RELEASE: version 2.2.0_alpha 2013-09-03 General 2HDM implemented 2013-08-18 Rescanning/recalculating events 2013-06-07 Reconstruction of complete event from 4-momenta possible 2013-05-06 Process library stacks 2013-05-02 Process stacks 2013-04-29 Single-particle phase space module 2013-04-26 Abstract interface for random number generator 2013-04-24 More object-orientation on modules Midpoint-rule integrator 2013-04-05 Object-oriented integration and event generation 2013-03-12 Processes recasted object-oriented: MEs, scales, structure functions First infrastructure for general Lorentz structures 2013-01-17 Object-orientated reworking of library and process core, more variable internal structure, unit tests 2012-12-14 Update Pythia version to 6.4.27 2012-12-04 Fix the phase in HAZ vertices 2012-11-21 First O'Mega unit tests, some infrastructure 2012-11-13 Bugfix in anom. HVV Lorentz structures ################################################################## 2012-09-18 RELEASE: version 2.1.1 2012-09-11 Model MSSM_Hgg with Hgg and HAA vertices 2012-09-10 First version of implementation of multiple interactions in WHIZARD 2012-09-05 Infrastructure for internal CKKW matching 2012-09-02 C, C++, Python API 2012-07-19 Fixing particle numbering in HepMC format ################################################################## 2012-06-15 RELEASE: version 2.1.0 2012-06-14 Analytical and kT-ordered shower officially released PYTHIA interface officially released 2012-05-09 Intrisince PDFs can be used for showering 2012-05-04 Anomalous Higgs couplings a la hep-ph/9902321 ################################################################## 2012-03-19 RELEASE: version 2.0.7 2012-03-15 Run IDs are available now More event variables in analysis Modified raw event format (compatibility mode exists) 2012-03-12 Bugfix in decay-integration order MLM matching steered completely internally now 2012-03-09 Special phase space mapping for narrow resonances decaying to 4-particle final states with far off-shell intermediate states Running alphas from PDF collaborations with builtin PDFs 2012-02-16 Bug fix in cascades decay infrastructure 2012-02-04 WHIZARD documentation compatible with TeXLive 2011 2012-02-01 Bug fix in FeynRules interface with --prefix flag 2012-01-29 Bug fix with name clash of O'Mega variable names 2012-01-27 Update internal PYTHIA to version 6.4.26 Bug fix in LHEF output 2012-01-21 Catching stricter automake 1.11.2 rules 2011-12-23 Bug fix in decay cascade setup 2011-12-20 Bug fix in helicity selection rules 2011-12-16 Accuracy goal reimplemented 2011-12-14 WHIZARD compatible with TeXLive 2011 2011-12-09 Option --user-target added ################################################################## 2011-12-07 RELEASE: version 2.0.6 2011-12-07 Bug fixes in SM_top_anom Added missing entries to HepMC format 2011-12-06 Allow to pass options to O'Mega Bug fix for HEPEVT block for showered/hadronized events 2011-12-01 Reenabled user plug-in for external code for cuts, structure functions, routines etc. 2011-11-29 Changed model SM_Higgs for Higgs phenomenology 2011-11-25 Supporting a Y, (B-L) Z' model 2011-11-23 Make WHIZARD compatible for MAC OS X Lion/XCode 4 2011-09-25 WHIZARD paper published: Eur.Phys.J. C71 (2011) 1742 2011-08-16 Model SM_QCD: QCD with one EW insertion 2011-07-19 Explicit output channel for dvips avoids printing 2011-07-10 Test suite for WHIZARD unit tests 2011-07-01 Commands for matrix element tests More OpenMP parallelization of kinematics Added unit tests 2011-06-23 Conversion of CIRCE2 from F77 to F90, major clean-up 2011-06-14 Conversion of CIRCE1 from F77 to F90 2011-06-10 OpenMP parallelization of channel kinematics (by Matthias Trudewind) 2011-05-31 RELEASE: version 1.97 2011-05-24 Minor bug fixes: update grids and elsif statement. ################################################################## 2011-05-10 RELEASE: version 2.0.5 2011-05-09 Fixed bug in final state flavor sums Minor improvements on phase-space setup 2011-05-05 Minor bug fixes 2011-04-15 WHIZARD as a precompiled 64-bit binary available 2011-04-06 Wall clock instead of cpu time for time estimates 2011-04-05 Major improvement on the phase space setup 2011-04-02 OpenMP parallelization for helicity loop in O'Mega matrix elements 2011-03-31 Tools for relocating WHIZARD and use in batch environments 2011-03-29 Completely static builds possible, profiling options 2011-03-28 Visualization of integration history 2011-03-27 Fixed broken K-matrix implementation 2011-03-23 Including the GAMELAN manual in the distribution 2011-01-26 WHIZARD analysis can handle hadronized event files 2011-01-17 MSTW2008 and CT10 PDF sets included 2010-12-23 Inclusion of NMSSM with Hgg couplings 2010-12-21 Advanced options for integration passes 2010-11-16 WHIZARD supports CTEQ6 and possibly other PDFs directly; data files included in the distribution ################################################################## 2010-10-26 RELEASE: version 2.0.4 2010-10-06 Bug fix in MSSM implementation 2010-10-01 Update to libtool 2.4 2010-09-29 Support for anomalous top couplings (form factors etc.) Bug fix for running gauge Yukawa SUSY couplings 2010-09-28 RELEASE: version 1.96 2010-09-21 Beam remnants and pT spectra for lepton collider re-enabled Restructuring subevt class 2010-09-16 Shower and matching are disabled by default PYTHIA as a conditional on these two options 2010-09-14 Possibility to read in beam spectra re-enabled (e.g. Guinea Pig) 2010-09-13 Energy scan as (pseudo-) structure functions re-implemented 2010-09-10 CIRCE2 included again in WHIZARD 2 and validated 2010-09-02 Re-implementation of asymmetric beam energies and collision angles, e-p collisions work, inclusion of a HERA DIS test case ################################################################## 2010-10-18 RELEASE: version 2.0.3 2010-08-08 Bug in CP-violating anomalous triple TGCs fixed 2010-08-06 Solving backwards compatibility problem with O'Caml 3.12.0 2010-07-12 Conserved quantum numbers speed up O'Mega code generation 2010-07-07 Attaching full ISR/FSR parton shower and MPI/ISR module Added SM model containing Hgg, HAA, HAZ vertices 2010-07-02 Matching output available as LHEF and STDHEP 2010-06-30 Various bug fixes, missing files, typos 2010-06-26 CIRCE1 completely re-enabled Chaining structure functions supported 2010-06-25 Partial support for conserved quantum numbers in O'Mega 2010-06-21 Major upgrade of the graphics package: error bars, smarter SINDARIN steering, documentation, and all that... 2010-06-17 MLM matching with PYTHIA shower included 2010-06-16 Added full CIRCE1 and CIRCE2 versions including full documentation and miscellanea to the trunk 2010-06-12 User file management supported, improved variable and command structure 2010-05-24 Improved handling of variables in local command lists 2010-05-20 PYTHIA interface re-enabled 2010-05-19 ASCII file formats for interfacing ROOT and gnuplot in data analysis ################################################################## 2010-05-18 RELEASE: version 2.0.2 2010-05-14 Reimplementation of visualization of phase space channels Minor bug fixes 2010-05-12 Improved phase space - elimination of redundancies 2010-05-08 Interface for polarization completed: polarized beams etc. 2010-05-06 Full quantum numbers appear in process log Integration results are usable as user variables Communication with external programs 2010-05-05 Split module commands into commands, integration, simulation modules 2010-05-04 FSR+ISR for the first time connected to the WHIZARD 2 core ################################################################## 2010-04-25 RELEASE: version 2.0.1 2010-04-23 Automatic compile and integrate if simulate is called Minor bug fixes in O'Mega 2010-04-21 Checkpointing for event generation Flush statements to use WHIZARD inside a pipe 2010-04-20 Reimplementation of signal handling in WGIZARD 2.0 2010-04-19 VAMP is now a separately configurable and installable unit of WHIZARD, included VAMP self-checks Support again compilation in quadruple precision 2010-04-06 Allow for logarithmic plots in GAMELAN, reimplement the possibility to set the number of bins 2010-04-15 Improvement on time estimates for event generation ################################################################## 2010-04-12 RELEASE: version 2.0.0 2010-04-09 Per default, the code for the amplitudes is subdivided to allow faster compiler optimization More advanced and unified and straightforward command language syntax Final bug fixes 2010-04-07 Improvement on SINDARIN syntax; printf, sprintf function thorugh a C interface 2010-04-05 Colorizing DAGs instead of model vertices: speed boost in colored code generation 2010-03-31 Generalized options for normalization of weighted and unweighted events Grid and weight histories added again to log files Weights can be used in analyses 2010-03-28 Cascade decays completely implemented including color and spin correlations 2010-03-07 Added new WHIZARD header with logo 2010-03-05 Removed conflict in O'Mega amplitudes between flavour sums and cascades StdHEP interface re-implemented 2010-03-03 RELEASE: version 2.0.0rc3 Several bug fixes for preventing abuse in input files OpenMP support for amplitudes Reimplementation of WHIZARD 1 HEPEVT ASCII event formats FeynRules interface successfully passed MSSM test 2010-02-26 Eliminating ghost gluons from multi-gluon amplitudes 2010-02-25 RELEASE: version 1.95 HEPEVT format from WHIZARD 1 re-implemented in WHIZARD 2 2010-02-23 Running alpha_s implemented in the FeynRules interface 2010-02-19 MSSM (semi-) automatized self-tests finalized 2010-02-17 RELEASE: version 1.94 2010-02-16 Closed memory corruption in WHIZARD 1 Fixed problems of old MadGraph and CompHep drivers with modern compilers Uncolored vertex selection rules for colored amplitudes in O'Mega 2010-02-15 Infrastructure for color correlation computation in O'Mega finished Forbidden processes are warned about, but treated as non-fatal 2010-02-14 Color correlation computation in O'Mega finalized 2010-02-10 Improving phase space mappings for identical particles in initial and final states Introduction of more extended multi-line error message 2010-02-08 First O'Caml code for computation of color correlations in O'Mega 2010-02-07 First MLM matching with e+ e- -> jets ################################################################## 2010-02-06 RELEASE: version 2.0.0rc2 2010-02-05 Reconsidered the Makefile structure and more extended tests Catch a crash between WHIZARD and O'Mega for forbidden processes Tensor products of arbitrary color structures in jet definitions 2010-02-04 Color correlation computation in O'Mega finalized ################################################################## 2010-02-03 RELEASE: version 2.0.0rc1 ################################################################## 2010-01-31 Reimplemented numerical helicity selection rules Phase space functionality of version 1 restored and improved 2009-12-05 NMSSM validated with FeynRules in WHIZARD 1 (Felix Braam) 2009-12-04 RELEASE: version 2.0.0alpha ################################################################## 2009-04-16 RELEASE: version 1.93 2009-04-15 Clean-up of Makefiles and configure scripts Reconfiguration of BSM model implementation extended supersymmetric models 2008-12-23 New model NMSSM (Felix Braam) SLHA2 added Bug in LHAPDF interface fixed 2008-08-16 Bug fixed in K matrix implementation Gravitino option in the MSSM added 2008-03-20 Improved color and flavor sums ################################################################## 2008-03-12 RELEASE: version 1.92 LHEF (Les Houches Event File) format added Fortran 2003 command-line interface (if supported by the compiler) Automated interface to colored models More bug fixes and workarounds for compiler compatibility ################################################################## 2008-03-06 RELEASE: version 1.91 New model K-matrix (resonances and anom. couplings in WW scattering) EWA spectrum Energy-scan pseudo spectrum Preliminary parton shower module (only from final-state quarks) Cleanup and improvements of configure process Improvements for O'Mega parameter files Quadruple precision works again More plotting options: lines, symbols, errors Documentation with PDF bookmarks enabled Various bug fixes 2007-11-29 New model UED ################################################################## 2007-11-23 RELEASE: version 1.90 O'Mega now part of the WHIZARD tree Madgraph/CompHEP disabled by default (but still usable) Support for LHAPDF (preliminary) Added new models: SMZprime, SM_km, Template Improved compiler recognition and compatibility Minor bug fixes ################################################################## 2006-06-15 RELEASE: version 1.51 Support for anomaly-type Higgs couplings (to gluon and photon/Z) Support for spin 3/2 and spin 2 New models: Little Higgs (4 versions), toy models for extra dimensions and gravitinos Fixes to the whizard.nw source documentation to run through LaTeX Intel 9.0 bug workaround (deallocation of some arrays) 2006-05-15 O'Mega RELEASE: version 0.11 merged JRR's O'Mega extensions ################################################################## 2006-02-07 RELEASE: version 1.50 To avoid confusion: Mention outdated manual example in BUGS file O'Mega becomes part of the WHIZARD generator 2006-02-02 [bug fix update] Bug fix: spurious error when writing event files for weighted events Bug fix: 'r' option for omega produced garbage for some particle names Workaround for ifort90 bug (crash when compiling whizard_event) Workaround for ifort90 bug (crash when compiling hepevt_common) 2006-01-27 Added process definition files for MSSM 2->2 processes Included beam recoil for EPA (T.Barklow) Updated STDHEP byte counts (for STDHEP 5.04.02) Fixed STDHEP compatibility (avoid linking of incomplete .so libs) Fixed issue with comphep requiring Xlibs on Opteron Fixed issue with ifort 8.x on Opteron (compiling 'signal' interface) Fixed color-flow code: was broken for omega with option 'c' and 'w' Workaround hacks for g95 compatibility 2005-11-07 O'Mega RELEASE: version 0.10 O'Mega, merged JRR's and WK's color hack for WHiZard O'Mega, EXPERIMENTAL: cache fusion tables (required for colors a la JRR/WK) O'Mega, make JRR's MSSM official ################################################################## 2005-10-25 RELEASE: version 1.43 Minor fixes in MSSM couplings (Higgs/3rd gen squarks). This should be final, since the MSSM results agree now completely with Madgraph and Sherpa User-defined lower and upper limits for split event file count Allow for counters (events, bytes) exceeding $2^{31}$ Revised checksum treatment and implementation (now MD5) Bug fix: missing process energy scale in raw event file ################################################################## 2005-09-30 RELEASE: version 1.42 Graphical display of integration history ('make history') Allow for switching off signals even if supported (configure option) 2005-09-29 Revised phase space generation code, in particular for flavor sums Negative cut and histogram codes use initial beams instead of initial parton momenta. This allows for computing, e.g., E_miss Support constant-width and zero-width options for O'Mega Width options now denoted by w:X (X=f,c,z). f option obsolescent Bug fix: colorized code: flipped indices could screw up result Bug fix: O'Mega with 'c' and 'w:f' option together (still some problem) Bug fix: dvips on systems where dvips defaults to lpr Bug fix: integer overflow if too many events are requested 2005-07-29 Allow for 2 -> 1 processes (if structure functions are on) 2005-07-26 Fixed and expanded the 'test' matrix element: Unit matrix element with option 'u' / default: normalized phase space ################################################################## 2005-07-15 RELEASE: version 1.41 Bug fix: no result for particle decay processes with width=0 Bug fix: line breaks in O'Mega files with color decomposition 2005-06-02 New self-tests (make test-QED / test-QCD / test-SM) check lists of 2->2 processes Bug fix: HELAS calling convention for wwwwxx and jwwwxx (4W-Vertex) 2005-05-25 Revised Makefile structure Eliminated obsolete references to ISAJET/SUSY (superseded by SLHA) 2005-05-19 Support for color in O'Mega (using color flow decomposition) New model QCD Parameter file changes that correspond to replaced SM module in O'Mega Bug fixes in MSSM (O'Mega) parameter file 2005-05-18 New event file formats, useful for LHC applications: ATHENA and Les Houches Accord (external fragmentation) Naive (i.e., leading 1/N) color factor now implemented both for incoming and outgoing partons 2005-01-26 include missing HELAS files for bundle pgf90 compatibility issues [note: still internal error in pgf90] ################################################################## 2004-12-13 RELEASE: version 1.40 compatibility fix: preprocessor marks in helas code now commented out minor bug fix: format string in madgraph source 2004-12-03 support for arbitray beam energies and directions allow for pT kick in structure functions bug fix: rounding error could result in zero cross section (compiler-dependent) 2004-10-07 simulate decay processes list fraction (of total width/cross section) instead of efficiency in process summary new cut/analysis parameters AA, AAD, CTA: absolute polar angle 2004-10-04 Replaced Madgraph I by Madgraph II. Main improvement: model no longer hardcoded introduced parameter reset_seed_each_process (useful for debugging) bug fix: color initialization for some processes was undefined 2004-09-21 don't compile unix_args module if it is not required ################################################################## 2004-09-20 RELEASE: version 1.30 g95 compatibility issues resolved some (irrelevant) memory leaks closed removed obsolete warning in circe1 manual update (essentially) finished 2004-08-03 O'Mega RELEASE: version 0.9 O'Mega, src/trie.mli, src/trie.ml: make interface compatible with the O'Caml 3.08 library (remains compatible with older versions). Implementation of unused functions still incomplete. 2004-07-26 minor fixes and improvements in make process 2004-06-29 workarounds for new Intel compiler bugs ... no rebuild of madgraph/comphep executables after 'make clean' bug fix in phase space routine: wrong energy for massive initial particles bug fix in (new) model interface: name checks for antiparticles pre-run checks for comphep improved ww-strong model file extended Model files particle name fixes, chep SM vertices included 2004-06-22 O'Mega RELEASE: version 0.8 O'Mega MSSM: sign of W+/W-/A and W+/W-/Z couplings 2004-05-05 Fixed bug in PDFLIB interface: p+pbar was initialized as p+p (ThO) NAG compiler: set number of continuation lines to 200 as default Extended format for cross section summary; appears now in whizard.out Fixed 'bundle' feature 2004-04-28 Fixed compatibility with revised O'Mega SM_ac model Fixed problem with x=0 or x=1 when calling PDFLIB (ThO) Fixed bug in comphep module: Vtb was overlooked ################################################################## 2004-04-15 RELEASE: version 1.28 Fixed bug: Color factor was missing for O'Mega processes with four quarks and more Manual partially updated 2004-04-08 Support for grid files in binary format New default value show_histories=F (reduce output file size) Revised phase space switches: removed annihilation_lines, removed s_channel_resonance, changed meaning of extra_off_shell_lines, added show_deleted_channels Bug fixed which lead to omission of some phase space channels Color flow guessed only if requested by guess_color_flow 2004-03-10 New model interface: Only one model name specified in whizard.prc All model-dependent files reside in conf/models (modellib removed) 2004-03-03 Support for input/output in SUSY Les Houches Accord format Split event files if requested Support for overall time limit Support for CIRCE and CIRCE2 generator mode Support for reading beam events from file 2004-02-05 Fixed compiler problems with Intel Fortran 7.1 and 8.0 Support for catching signals ################################################################## 2003-08-06 RELEASE: version 1.27 User-defined PDF libraries as an alternative to the standard PDFLIB 2003-07-23 Revised phase space module: improved mappings for massless particles, equivalences of phase space channels are exploited Improved mapping for PDF (hadron colliders) Madgraph module: increased max number of color flows from 250 to 1000 ################################################################## 2003-06-23 RELEASE: version 1.26 CIRCE2 support Fixed problem with 'TC' integer kind [Intel compiler complained] 2003-05-28 Support for drawing histograms of grids Bug fixes for MSSM definitions ################################################################## 2003-05-22 RELEASE: version 1.25 Experimental MSSM support with ISAJET interface Improved capabilities of generating/analyzing weighted events Optional drawing phase space diagrams using FeynMF ################################################################## 2003-01-31 RELEASE: version 1.24 A few more fixes and workarounds (Intel and Lahey compiler) 2003-01-15 Fixes and workarounds needed for WHIZARD to run with Intel compiler Command-line option interface for the Lahey compiler Bug fix: problem with reading whizard.phs ################################################################## 2002-12-10 RELEASE: version 1.23 Command-line options (on some systems) Allow for initial particles in the event record, ordered: [beams, initials] - [remnants] - outgoing partons Support for PYTHIA 6.2: Les Houches external process interface String pythia_parameters can be up to 1000 characters long Select color flow states in (internal) analysis Bug fix in color flow content of raw event files Support for transversal polarization of fermion beams Cut codes: PHI now for absolute azimuthal angle, DPHI for distance 'Test' matrix elements optionally respect polarization User-defined code can be inserted for spectra, structure functions and fragmentation Time limits can be specified for adaptation and simulation User-defined file names and file directory Initial weights in input file no longer supported Bug fix in MadGraph (wave function counter could overflow) Bug fix: Gamelan (graphical analysis) was not built if noweb absent ################################################################## 2002-03-16 RELEASE: version 1.22 Allow for beam remnants in the event record 2002-03-01 Handling of aliases in whizard.prc fixed (aliases are whole tokens) 2002-02-28 Optimized phase space handling routines (total execution time reduced by 20-60%, depending on process) ################################################################## 2002-02-26 RELEASE: version 1.21 Fixed ISR formula (ISR was underestimated in previous versions). New version includes ISR in leading-log approximation up to third order. Parameter ISR_sqrts renamed to ISR_scale. ################################################################## 2002-02-19 RELEASE: version 1.20 New process-generating method 'test' (dummy matrix element) Compatibility with autoconf 2.50 and current O'Mega version 2002-02-05 Prevent integration channels from being dropped (optionally) New internal mapping for structure functions improves performance Old whizard.phx file deleted after recompiling (could cause trouble) 2002-01-24 Support for user-defined cuts and matrix element reweighting STDHEP output now written by write_events_format=20 (was 3) 2002-01-16 Improved structure function handling; small changes in user interface: new parameter structured_beams in &process_input parameter fixed_energy in &beam_input removed Support for multiple initial states Eta-phi (cone) cut possible (hadron collider applications) Fixed bug: Whizard library was not always recompiled when necessary Fixed bug: Default cuts were insufficient in some cases Fixed bug: Unusable phase space mappings generated in some cases 2001-12-06 Reorganized document source 2001-12-05 Preliminary CIRCE2 support (no functionality yet) 2001-11-27 Intel compiler support (does not yet work because of compiler bugs) New cut and analysis mode cos-theta* and related Fixed circular jetset_interface dependency warning Some broadcast routines removed (parallel support disabled anyway) Minor shifts in cleanup targets (Makefiles) Modified library search, check for pdflib8* 2001-08-06 Fixed bug: I/O unit number could be undefined when reading phase space Fixed bug: Unitialized variable could cause segfault when event generation was disabled Fixed bug: Undefined subroutine in CIRCE replacement module Enabled feature: TGCs in O'Mega (not yet CompHEP!) matrix elements (CompHEP model sm-GF #5, O'Mega model SM_ac) Fixed portability issue: Makefile did rely on PWD environment variable Fixed portability issue: PYTHIA library search ambiguity resolved 2001-08-01 Default whizard.prc and whizard.in depend on activated modules Fixed bug: TEX=latex was not properly enabled when making plots 2001-07-20 Fixed output settings in PERL script calls Cache enabled in various configure checks 2001-07-13 Support for multiple processes in a single WHIZARD run. The integrations are kept separate, but the generated events are mixed The whizard.evx format has changed (incompatible), including now the color flow information for PYTHIA fragmentation Output files are now process-specific, except for the event file Phase space file whizard.phs (if present) is used only as input, program-generated phase space is now in whizard.phx 2001-07-10 Bug fix: Undefined parameters in parameters_SM_ac.f90 removed 2001-07-04 Bug fix: Compiler options for the case OMEGA is disabled Small inconsistencies in whizard.out format fixed 2001-07-01 Workaround for missing PDFLIB dummy routines in PYTHIA library ################################################################## 2001-06-30 RELEASE: version 1.13 Default path /cern/pro/lib in configure script 2001-06-20 New fragmentation option: Interface for PYTHIA with full color flow information, beam remnants etc. 2001-06-18 Severe bug fixed in madgraph interface: 3-gluon coupling was missing Enabled color flow information in madgraph 2001-06-11 VAMP interface module rewritten Revised output format: Multiple VAMP iterations count as one WHIZARD iteration in integration passes 1 and 3 Improved message and error handling Bug fix in VAMP: handle exceptional cases in rebinning_weights 2001-05-31 new parameters for grid adaptation: accuracy_goal and efficiency_goal ################################################################## 2001-05-29 RELEASE: version 1.12 bug fixes (compilation problems): deleted/modified unused functions 2001-05-16 diagram selection improved and documented 2001-05-06 allow for disabling packages during configuration 2001-05-03 slight changes in whizard.out format; manual extended ################################################################## 2001-04-20 RELEASE: version 1.11 fixed some configuration and compilation problems (PDFLIB etc.) 2001-04-18 linked PDFLIB: support for quark/gluon structure functions 2001-04-05 parameter interface written by PERL script SM_ac model file: fixed error in continuation line 2001-03-13 O'Mega, O'Caml 3.01: incompatible changes O'Mega, src/trie.mli: add covariance annotation to T.t This breaks O'Caml 3.00, but is required for O'Caml 3.01. O'Mega, many instances: replace `sig include Module.T end' by `Module.T', since the bug is fixed in O'Caml 3.01 2001-02-28 O'Mega, src/model.mli: new field Model.vertices required for model functors, will retire Model.fuse2, Model.fuse3, Model.fusen soon. ################################################################## 2001-03-27 RELEASE: version 1.10 reorganized the modules as libraries linked PYTHIA: support for parton fragmentation 2000-12-14 fixed some configuration problems (if noweb etc. are absent) ################################################################## 2000-12-01 RELEASE of first public version: version 1.00beta Index: trunk/src/model_features/model_features.nw =================================================================== --- trunk/src/model_features/model_features.nw (revision 8345) +++ trunk/src/model_features/model_features.nw (revision 8346) @@ -1,16975 +1,16980 @@ % -*- 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 @ [[gfortran 4.7.4]] does not support allocate-on-assignment for the caller when this is a function. <>= 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 allocate (prt_string(size (queue%current_prt%prt_string))) 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 integer :: i !!! !!! !!! Explicit allocation due to gfortran 4.7.4 allocate (generator%pdg_in_born (size (pdg_in))) do i = 1, size (pdg_in) generator%pdg_in_born(i) = pdg_in(i) end do allocate (generator%pdg_out_born (size (pdg_out))) do i = 1, size (pdg_out) generator%pdg_out_born(i) = pdg_out(i) end do 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 user_code_interface 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_UOBS1_INT = 31, EN_UOBS2_INT = 32 integer, parameter :: EN_UOBS1_REAL = 41, EN_UOBS2_REAL = 42 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_UOBS1_INT EN_UOBS2_INT EN_UOBS1_REAL EN_UOBS2_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 :: 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 @ These nodes refer to user-defined procedures. <>= subroutine eval_node_init_uobs1_int (node, name, arg) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(eval_node_t), intent(in), target :: arg node%type = EN_UOBS1_INT node%tag = name node%result_type = V_INT allocate (node%ival, node%value_is_known) node%value_is_known = .false. node%arg0 => arg end subroutine eval_node_init_uobs1_int subroutine eval_node_init_uobs2_int (node, name, arg) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(eval_node_t), intent(in), target :: arg node%type = EN_UOBS2_INT node%tag = name node%result_type = V_INT allocate (node%ival, node%value_is_known) node%value_is_known = .false. node%arg0 => arg end subroutine eval_node_init_uobs2_int subroutine eval_node_init_uobs1_real (node, name, arg) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(eval_node_t), intent(in), target :: arg node%type = EN_UOBS1_REAL node%tag = name node%result_type = V_REAL allocate (node%rval, node%value_is_known) node%value_is_known = .false. node%arg0 => arg end subroutine eval_node_init_uobs1_real subroutine eval_node_init_uobs2_real (node, name, arg) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(eval_node_t), intent(in), target :: arg node%type = EN_UOBS2_REAL node%tag = name node%result_type = V_REAL allocate (node%rval, node%value_is_known) node%value_is_known = .false. node%arg0 => arg end subroutine eval_node_init_uobs2_real @ %def eval_node_init_uobs1_int @ %def eval_node_init_uobs2_int @ %def eval_node_init_uobs1_real @ %def eval_node_init_uobs2_real @ \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, & EN_UOBS1_INT, EN_UOBS2_INT, EN_UOBS1_REAL, EN_UOBS2_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, EN_UOBS1_INT, EN_UOBS1_REAL) write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt1 =" call prt_write (node%prt1, unit) case (EN_OBS2_INT, EN_OBS2_REAL, EN_UOBS2_INT, EN_UOBS2_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. (Furthermore, the function version of [[unary_prt]] triggers an obscure bug in nagfor 5.2(649) [invalid C code].) <>= 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 !!! These are F2008 additions but accepted by nagfor 5.3 and gfortran 4.6+ !!! Currently not used. ! 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 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 call subevt_cluster (subevt, en1%pval, mask1, jet_def, keep_jets) 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 @ This is the interface to user-supplied observables. The node [[en0]] evaluates to a string that indicates the procedure name. We search for the procedure in the dynamic library and load it into the procedure pointer which is then called. [[en1]] is the subevent on which the external code operates. The external function returns a [[c_int]], which we translate into a real value. <>= function user_obs_int_p (en0, prt1) result (ival) integer :: ival type(eval_node_t), intent(inout) :: en0 type(prt_t), intent(in) :: prt1 type(string_t) :: name procedure(user_obs_int_unary), pointer :: user_obs call eval_node_evaluate (en0) if (en0%value_is_known) then select case (en0%result_type) case (V_STR); name = en0%sval case default call msg_bug ("user_obs: procedure name must be a string") name = "" end select call c_f_procpointer (user_code_find_proc (name), user_obs) ival = user_obs (c_prt (prt1)) else call eval_node_write_rec (en0) call msg_fatal ("User observable name is undefined") end if end function user_obs_int_p function user_obs_real_p (en0, prt1) result (rval) real(default) :: rval type(eval_node_t), intent(inout) :: en0 type(prt_t), intent(in) :: prt1 type(string_t) :: name procedure(user_obs_real_unary), pointer :: user_obs call eval_node_evaluate (en0) if (en0%value_is_known) then select case (en0%result_type) case (V_STR); name = en0%sval case default call msg_bug ("user_obs: procedure name must be a string") name = "" end select call c_f_procpointer (user_code_find_proc (name), user_obs) rval = user_obs (c_prt (prt1)) else call eval_node_write_rec (en0) call msg_fatal ("User observable name is undefined") end if end function user_obs_real_p @ %def user_obs_int_p @ %def user_obs_real_p @ This is the interface to user-supplied cut code. The node [[en0]] evaluates to a string that indicates the procedure name. <>= function user_cut_p (en1, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 type(string_t) :: name procedure(user_cut_fun), pointer :: user_cut call eval_node_evaluate (en0) select case (en0%result_type) case (V_STR); name = en0%sval case default call msg_bug ("user_cut: procedure name must be a string") name = "" end select call c_f_procpointer (user_code_find_proc (name), user_cut) lval = user_cut (c_prt (en1%pval), & int (subevt_get_length (en1%pval), kind=c_int)) & /= 0 end function user_cut_p @ %def user_cut_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. A function would be more natural. Making it a subroutine avoids another compiler bug (internal error in nagfor 5.2 (649)). (See the interface [[unary_evi]].) <>= 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 @ This evaluates a user-defined event-shape observable for the current subevent. <>= subroutine user_event_shape_a (rval, en1, en0) real(default), intent(out) :: rval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 type(string_t) :: name procedure(user_event_shape_fun), pointer :: user_event_shape if (.not. present (en0)) call msg_bug & ("user_event_shape called without procedure name") call eval_node_evaluate (en0) select case (en0%result_type) case (V_STR); name = en0%sval case default call msg_bug ("user_event_shape: procedure name must be a string") name = "" end select call c_f_procpointer (user_code_find_proc (name), user_event_shape) rval = user_event_shape (c_prt (en1%pval), & int (subevt_get_length (en1%pval), kind=c_int)) end subroutine user_event_shape_a @ %def user_event_shape_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_pp @ This is the interface to user-supplied observables. The node [[en0]] evaluates to a string that indicates the procedure name. We search for the procedure in the dynamic library and load it into the procedure pointer which is then called. [[en1]] is the subevent on which the external code operates. The external function returns a [[c_int]], which we translate into a real value. <>= function user_obs_int_pp (en0, prt1, prt2) result (ival) integer :: ival type(eval_node_t), intent(inout) :: en0 type(prt_t), intent(in) :: prt1, prt2 type(string_t) :: name procedure(user_obs_int_binary), pointer :: user_obs call eval_node_evaluate (en0) if (en0%value_is_known) then select case (en0%result_type) case (V_STR); name = en0%sval case default call msg_bug ("user_obs: procedure name must be a string") name = "" end select call c_f_procpointer (user_code_find_proc (name), user_obs) ival = user_obs (c_prt (prt1), c_prt (prt2)) else call eval_node_write_rec (en0) call msg_fatal ("User observable name is undefined") end if end function user_obs_int_pp function user_obs_real_pp (en0, prt1, prt2) result (rval) real(default) :: rval type(eval_node_t), intent(inout) :: en0 type(prt_t), intent(in) :: prt1, prt2 type(string_t) :: name procedure(user_obs_real_binary), pointer :: user_obs call eval_node_evaluate (en0) if (en0%value_is_known) then select case (en0%result_type) case (V_STR); name = en0%sval case default call msg_bug ("user_obs: procedure name must be a string") name = "" end select call c_f_procpointer (user_code_find_proc (name), user_obs) rval = user_obs (c_prt (prt1), c_prt (prt2)) else call eval_node_write_rec (en0) call msg_fatal ("User observable name is undefined") end if end function user_obs_real_pp @ %def user_obs_int_pp @ %def user_obs_real_pp @ 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. A function would be more natural. Making it a subroutine avoids another compiler bug (internal error in nagfor 5.2 (649)). (See the interface [[binary_num]].) <>= 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 ("user_observable") call eval_node_compile_user_observable (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", "user_event_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 @ This user observable behaves like a variable. We link the node to the generic user-observable entry in the variable list. The syntax element has an argument which provides the name of the user variable, this is stored as an eval-node alongside with the variable. When the variable value is used, the user-supplied external function is called and provides the (real) result value. <>= subroutine eval_node_compile_user_observable (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_arg, pn_obs type(eval_node_t), pointer :: en0 integer :: res_type type(string_t) :: var_name integer :: type logical :: defined if (debug_active (D_MODEL_F)) then print *, "read user observable"; call parse_node_write (pn) end if pn_key => parse_node_get_sub_ptr (pn) select case (char (parse_node_get_key (pn_key))) case ("user_obs") res_type = V_REAL case default call parse_node_write (pn_key) call msg_bug ("user_observable: wrong keyword") end select pn_arg => parse_node_get_next_ptr (pn_key) pn_obs => parse_node_get_sub_ptr (pn_arg) call eval_node_compile_sexpr (en0, pn_obs, var_list) select case (res_type) case (V_INT); var_name = "_User_obs_int" case (V_REAL); var_name = "_User_obs_real" end select call var_list%get_var_properties (var_name, type=type, is_defined=defined) allocate (en) if (defined) then select case (type) case (V_UOBS1_INT) call eval_node_init_uobs1_int (en, var_name, en0) case (V_UOBS2_INT) call eval_node_init_uobs2_int (en, var_name, en0) case (V_UOBS1_REAL) call eval_node_init_uobs1_real (en, var_name, en0) case (V_UOBS2_REAL) call eval_node_init_uobs2_real (en, var_name, en0) end select else call parse_node_write (pn) call msg_error ("This variable is undefined at this point") end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done user observable" end if end subroutine eval_node_compile_user_observable @ %def eval_node_compile_user_observable @ 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 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 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", "user_cut_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) 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 ("user_cut_fun") pn_key => parse_node_get_sub_ptr (pn) pn_str => parse_node_get_next_ptr (pn_key) pn_arg0 => parse_node_get_sub_ptr (pn_str) pn_args => parse_node_get_next_ptr (pn_str) case default call parse_node_mismatch ("all_fun|any_fun|" // & "no_fun|photon_isolation_fun|user_cut_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 ("user_cut") call eval_node_init_log_fun_unary (en, en1, key, user_cut_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 ("user_cut") call eval_node_compile_sexpr (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) case ("user_event_fun") pn_key => parse_node_get_sub_ptr (pn) pn_cond => parse_node_get_next_ptr (pn_key) pn_arg0 => parse_node_get_sub_ptr (pn_cond) pn_args => parse_node_get_next_ptr (pn_cond) 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 ("user_event_shape") call eval_node_init_real_fun_unary (en, en1, key, user_event_shape_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) case ("user_event_shape") call eval_node_compile_sexpr (en0, pn_arg0, en%var_list) call eval_node_set_expr (en, en0, V_REAL) 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_UOBS1_INT) en%ival = user_obs_int_p (en%arg0, en%prt1) en%value_is_known = .true. case (EN_UOBS2_INT) en%ival = user_obs_int_pp (en%arg0, en%prt1, en%prt2) en%value_is_known = .true. case (EN_UOBS1_REAL) en%rval = user_obs_real_p (en%arg0, en%prt1) en%value_is_known = .true. case (EN_UOBS2_REAL) en%rval = user_obs_real_pp (en%arg0, 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 | user_observable | " // & "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, "SEQ user_observable = user_obs user_arg") call ifile_append (ifile, "KEY user_obs") call ifile_append (ifile, "ARG user_arg = ( sexpr )") 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") 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, "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 | event_shape_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") call ifile_append (ifile, "ALT event_shape_fun = user_event_fun") call ifile_append (ifile, "SEQ user_event_fun = " & // "user_event_shape user_arg pargs1") call ifile_append (ifile, "KEY user_event_shape") 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 | user_cut_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") call ifile_append (ifile, "SEQ user_cut_fun = user_cut user_arg pargs1") call ifile_append (ifile, "KEY user_cut") 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 [[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(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_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{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 :: 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. Note: the auxiliary pointer [[value_ptr]] is a workaround for a bug in gfortran 4.8.1: the target of the function pointer is lost, if the pointer is provided directly as argument. <>= 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 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{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") 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 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, "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 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.) 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)) 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 <>= function read_frac (nd_frac, base) result (qn_type) integer :: qn_type type(parse_node_t), intent(in) :: nd_frac integer, intent(in) :: 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) else call parse_node_write_rec (nd_frac) call msg_fatal (" Fractional quantum number: wrong denominator") 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 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 @ \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. <>= 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, ifile) type(stream_t), intent(inout), target :: stream 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") mode = check_block_handling (line) 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 need to recognize only those blocks that we actually use. <>= function check_block_handling (line) result (mode) integer :: mode type(string_t), intent(in) :: line type(string_t) :: buffer, key, block_name buffer = trim (line) call split (buffer, key, " ") buffer = adjustl (buffer) call split (buffer, block_name, " ") 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 end select end function check_block_handling @ %def check_block_handling @ \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 block_spec '$' block_line*") call ifile_append (ifile, "KEY BLOCK") 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 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) if (trim (adjustl (upper_case (parse_node_get_string & (pn_block_name)))) == 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. 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 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 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: <>= 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=.true.) 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{Parser} Read a SLHA file from stream, including preprocessing, and make up a parse tree. <>= subroutine slha_parse_stream (stream, parse_tree) type(stream_t), intent(inout), target :: stream 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, 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. Required for test: <>= public :: slha_parse_file <>= subroutine slha_parse_file (file, os_data, parse_tree) type(string_t), intent(in) :: file 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, 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(parse_tree_t) :: parse_tree call slha_parse_file (file, 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 () 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"), 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 Index: trunk/tests/functional_tests/Makefile.am =================================================================== --- trunk/tests/functional_tests/Makefile.am (revision 8345) +++ trunk/tests/functional_tests/Makefile.am (revision 8346) @@ -1,784 +1,790 @@ ## Makefile.am -- Makefile for executable WHIZARD test scripts ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2019 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## WHIZARD_DRIVER = run_whizard.sh TESTS_DEFAULT = \ empty.run \ fatal.run \ structure_1.run \ structure_2.run \ structure_3.run \ structure_4.run \ structure_5.run \ structure_6.run \ structure_7.run \ structure_8.run \ vars.run \ extpar.run \ testproc_1.run \ testproc_2.run \ testproc_3.run \ testproc_4.run \ testproc_5.run \ testproc_6.run \ testproc_7.run \ testproc_8.run \ testproc_9.run \ testproc_10.run \ testproc_11.run \ testproc_12.run \ template_me_1.run \ template_me_2.run \ model_scheme_1.run \ rebuild_1.run \ rebuild_4.run \ susyhit.run \ helicity.run \ libraries_4.run \ job_id_1.run \ pack_1.run XFAIL_TESTS_DEFAULT = TESTS_REQ_FASTJET = \ analyze_4.run \ bjet_cluster.run \ openloops_12.run \ openloops_13.run TESTS_REQ_OCAML = \ libraries_1.run \ libraries_2.run \ libraries_3.run \ rebuild_2.run \ rebuild_3.run \ rebuild_5.run \ defaultcuts.run \ cuts.run \ model_change_1.run \ model_change_2.run \ model_change_3.run \ model_test.run \ job_id_2.run \ job_id_3.run \ job_id_4.run \ qedtest_1.run \ qedtest_2.run \ qedtest_3.run \ qedtest_4.run \ qedtest_5.run \ qedtest_6.run \ qedtest_7.run \ qedtest_8.run \ qedtest_9.run \ qedtest_10.run \ rambo_vamp_1.run \ rambo_vamp_2.run \ beam_setup_1.run \ beam_setup_2.run \ beam_setup_3.run \ beam_setup_4.run \ beam_setup_5.run \ qcdtest_1.run \ qcdtest_2.run \ qcdtest_3.run \ qcdtest_4.run \ qcdtest_5.run \ qcdtest_6.run \ observables_1.run \ observables_2.run \ event_weights_1.run \ event_weights_2.run \ event_eff_1.run \ event_eff_2.run \ event_dump_1.run \ event_dump_2.run \ reweight_1.run \ reweight_2.run \ reweight_3.run \ reweight_4.run \ reweight_5.run \ reweight_6.run \ reweight_7.run \ reweight_8.run \ analyze_1.run \ analyze_2.run \ analyze_5.run \ analyze_6.run \ colors.run \ colors_2.run \ colors_hgg.run \ alphas.run \ jets_xsec.run \ lhef_1.run \ lhef_2.run \ lhef_3.run \ lhef_4.run \ lhef_5.run \ lhef_6.run \ lhef_7.run \ lhef_8.run \ lhef_9.run \ lhef_10.run \ lhef_11.run \ stdhep_1.run \ stdhep_2.run \ stdhep_3.run \ stdhep_4.run \ stdhep_5.run \ stdhep_6.run \ select_1.run \ select_2.run \ fatal_beam_decay.run \ smtest_1.run \ smtest_2.run \ smtest_3.run \ smtest_4.run \ smtest_5.run \ smtest_6.run \ smtest_7.run \ smtest_8.run \ smtest_9.run \ smtest_10.run \ smtest_11.run \ smtest_12.run \ smtest_13.run \ smtest_14.run \ smtest_15.run \ smtest_16.run \ photon_isolation_1.run \ photon_isolation_2.run \ resonances_1.run \ resonances_2.run \ resonances_3.run \ resonances_4.run \ resonances_5.run \ resonances_6.run \ resonances_7.run \ resonances_8.run \ resonances_9.run \ resonances_10.run \ resonances_11.run \ resonances_12.run \ mssmtest_1.run \ mssmtest_2.run \ mssmtest_3.run \ sm_cms_1.run \ ufo_1.run \ ufo_2.run \ ufo_3.run \ + ufo_4.run \ nlo_1.run \ nlo_2.run \ nlo_3.run \ nlo_4.run \ nlo_5.run \ nlo_6.run \ nlo_decay_1.run \ real_partition_1.run \ fks_res_1.run \ fks_res_2.run \ fks_res_3.run \ openloops_1.run \ openloops_2.run \ openloops_3.run \ openloops_4.run \ openloops_5.run \ openloops_6.run \ openloops_7.run \ openloops_8.run \ openloops_9.run \ openloops_10.run \ openloops_11.run \ recola_1.run \ recola_2.run \ recola_3.run \ recola_4.run \ recola_5.run \ recola_6.run \ recola_7.run \ recola_8.run \ powheg_1.run \ spincor_1.run \ show_1.run \ show_2.run \ show_3.run \ show_4.run \ show_5.run \ method_ovm_1.run \ multi_comp_1.run \ multi_comp_2.run \ multi_comp_3.run \ multi_comp_4.run \ flvsum_1.run \ br_redef_1.run \ decay_err_1.run \ decay_err_2.run \ decay_err_3.run \ polarized_1.run \ pdf_builtin.run \ ep_1.run \ ep_2.run \ ep_3.run \ circe1_1.run \ circe1_2.run \ circe1_3.run \ circe1_4.run \ circe1_5.run \ circe1_6.run \ circe1_7.run \ circe1_8.run \ circe1_9.run \ circe1_10.run \ circe1_photons_1.run \ circe1_photons_2.run \ circe1_photons_3.run \ circe1_photons_4.run \ circe1_photons_5.run \ circe1_errors_1.run \ circe2_1.run \ circe2_2.run \ circe2_3.run \ ewa_1.run \ ewa_2.run \ ewa_3.run \ ewa_4.run \ isr_1.run \ isr_2.run \ isr_3.run \ isr_4.run \ isr_5.run \ epa_1.run \ epa_2.run \ isr_epa_1.run \ ilc.run \ gaussian_1.run \ gaussian_2.run \ beam_events_1.run \ beam_events_2.run \ beam_events_3.run \ beam_events_4.run \ energy_scan_1.run \ restrictions.run \ process_log.run \ shower_err_1.run \ parton_shower_1.run \ parton_shower_2.run \ hadronize_1.run \ mlm_matching_fsr.run \ user_cuts.run \ user_prc_threshold_1.run \ cascades2_phs_1.run \ user_prc_threshold_2.run \ vamp2_1.run \ vamp2_2.run XFAIL_TESTS_REQ_OCAML = \ colors_hgg.run \ hadronize_1.run \ user_cuts.run TESTS_REQ_HEPMC = \ hepmc_1.run \ hepmc_2.run \ hepmc_3.run \ hepmc_4.run \ hepmc_5.run \ hepmc_6.run \ hepmc_7.run \ hepmc_8.run \ hepmc_9.run \ hepmc_10.run XFAIL_TESTS_REQ_HEPMC = TESTS_REQ_LCIO = \ lcio_1.run \ lcio_2.run \ lcio_3.run \ lcio_4.run \ lcio_5.run \ lcio_6.run \ lcio_7.run \ lcio_8.run \ lcio_9.run \ lcio_10.run XFAIL_TESTS_REQ_LCIO = TESTS_REQ_LHAPDF5 = \ lhapdf5.run TESTS_REQ_LHAPDF6 = \ lhapdf6.run XFAIL_TESTS_REQ_LHAPDF5 = XFAIL_TESTS_REQ_LHAPDF6 = TESTS_STATIC = \ static_1.run \ static_2.run XFAIL_TESTS_STATIC = TESTS_REQ_PYTHIA6 = \ pythia6_1.run \ pythia6_2.run \ pythia6_3.run \ pythia6_4.run \ tauola_1.run \ tauola_2.run \ isr_5.run \ mlm_pythia6_isr.run \ mlm_matching_isr.run XFAIL_TESTS_REQ_PYTHIA6 = TESTS_REQ_PYTHIA8 = # pythia8_1.run \ # pythia8_2.run XFAIL_TESTS_REQ_PYTHIA8 = TESTS_REQ_EV_ANA = \ analyze_3.run XFAIL_TESTS_REQ_EV_ANA = TESTS_REQ_GAMELAN = \ analyze_3.run TEST_DRIVERS_RUN = \ $(TESTS_DEFAULT) \ $(TESTS_REQ_OCAML) \ $(TESTS_REQ_LHAPDF5) \ $(TESTS_REQ_LHAPDF6) \ $(TESTS_REQ_HEPMC) \ $(TESTS_REQ_LCIO) \ $(TESTS_REQ_FASTJET) \ $(TESTS_REQ_PYTHIA6) \ $(TESTS_REQ_EV_ANA) \ $(TESTS_STATIC) TEST_DRIVERS_SH = $(TEST_DRIVERS_RUN:.run=.sh) ######################################################################## TESTS = XFAIL_TESTS = TESTS_SRC = TESTS += $(TESTS_DEFAULT) XFAIL_TESTS += $(XFAIL_TESTS_DEFAULT) TESTS += $(TESTS_REQ_OCAML) XFAIL_TESTS += $(XFAIL_TESTS_REQ_OCAML) TESTS += $(TESTS_REQ_HEPMC) XFAIL_TESTS += $(XFAIL_TESTS_REQ_HEPMC) TESTS += $(TESTS_REQ_LCIO) XFAIL_TESTS += $(XFAIL_TESTS_REQ_LCIO) TESTS += $(TESTS_REQ_FASTJET) XFAIL_TESTS += $(XFAIL_TESTS_REQ_FASTJET) TESTS += $(TESTS_REQ_LHAPDF5) XFAIL_TESTS += $(XFAIL_TESTS_REQ_LHAPDF5) TESTS += $(TESTS_REQ_LHAPDF6) XFAIL_TESTS += $(XFAIL_TESTS_REQ_LHAPDF6) TESTS += $(TESTS_REQ_PYTHIA6) XFAIL_TESTS += $(XFAIL_TESTS_REQ_PYTHIA6) TESTS += $(TESTS_REQ_PYTHIA8) XFAIL_TESTS += $(XFAIL_TESTS_REQ_PYTHIA8) TESTS += $(TESTS_REQ_EV_ANA) XFAIL_TESTS += $(XFAIL_TESTS_REQ_EV_ANA) TESTS += $(TESTS_STATIC) XFAIL_TESTS += $(XFAIL_TESTS_STATIC) EXTRA_DIST = $(TEST_DRIVERS_SH) \ $(TESTS_SRC) ######################################################################## VPATH = $(srcdir) SUFFIXES = .sh .run .sh.run: @rm -f $@ @if test -f $(top_builddir)/share/tests/functional_tests/$*.sin; then \ $(SED) 's|@script@|$(top_builddir)/share/tests/functional_tests/$*|g' $< > $@; \ elif test -f $(top_srcdir)/share/tests/functional_tests/$*.sin; then \ $(SED) 's|@script@|$(top_srcdir)/share/tests/functional_tests/$*|g' $< > $@; \ else \ echo "$*.sin not found!" 1>&2; \ exit 2; \ fi @chmod +x $@ structure_2.run: structure_2_inc.sin structure_2_inc.sin: $(top_builddir)/share/tests/functional_tests/structure_2_inc.sin cp $< $@ testproc_3.run: testproc_3.phs testproc_3.phs: $(top_builddir)/share/tests/functional_tests/testproc_3.phs cp $< $@ static_1.run: static_1.exe.sin static_1.exe.sin: $(top_builddir)/share/tests/functional_tests/static_1.exe.sin cp $< $@ static_2.run: static_2.exe.sin static_2.exe.sin: $(top_builddir)/share/tests/functional_tests/static_2.exe.sin cp $< $@ susyhit.run: susyhit.in user_cuts.run: user_cuts.f90 user_cuts.f90: $(top_builddir)/share/tests/functional_tests/user_cuts.f90 cp $< $@ model_test.run: tdefs.$(FC_MODULE_EXT) tglue.$(FC_MODULE_EXT) \ threeshl.$(FC_MODULE_EXT) tscript.$(FC_MODULE_EXT) tdefs.mod: $(top_builddir)/src/models/threeshl_bundle/tdefs.$(FC_MODULE_EXT) cp $< $@ tglue.mod: $(top_builddir)/src/models/threeshl_bundle/tglue.$(FC_MODULE_EXT) cp $< $@ tscript.mod: $(top_builddir)/src/models/threeshl_bundle/tscript.$(FC_MODULE_EXT) cp $< $@ threeshl.mod: $(top_builddir)/src/models/threeshl_bundle/threeshl.$(FC_MODULE_EXT) cp $< $@ WT_OCAML_NATIVE_EXT=opt if OCAML_AVAILABLE OMEGA_QED = $(top_builddir)/omega/bin/omega_QED.$(WT_OCAML_NATIVE_EXT) OMEGA_QCD = $(top_builddir)/omega/bin/omega_QCD.$(WT_OCAML_NATIVE_EXT) OMEGA_MSSM = $(top_builddir)/omega/bin/omega_MSSM.$(WT_OCAML_NATIVE_EXT) omega_MSSM.$(WT_OMEGA_CACHE_SUFFIX): $(OMEGA_MSSM) $(OMEGA_MSSM) -initialize . UFO_TAG_FILE = __init__.py UFO_MODELPATH = ../models/UFO ufo_1.run: ufo_1_SM/$(UFO_TAG_FILE) ufo_2.run: ufo_2_SM/$(UFO_TAG_FILE) ufo_3.run: ufo_3_models/ufo_3_SM/$(UFO_TAG_FILE) +ufo_4.run: ufo_4_models/ufo_4_SM/$(UFO_TAG_FILE) ufo_1_SM/$(UFO_TAG_FILE): $(UFO_MODELPATH)/SM/$(UFO_TAG_FILE) mkdir -p ufo_1_SM cp $(UFO_MODELPATH)/SM/*.py ufo_1_SM ufo_2_SM/$(UFO_TAG_FILE): $(UFO_MODELPATH)/SM/$(UFO_TAG_FILE) mkdir -p ufo_2_SM cp $(UFO_MODELPATH)/SM/*.py ufo_2_SM ufo_3_models/ufo_3_SM/$(UFO_TAG_FILE): $(UFO_MODELPATH)/SM/$(UFO_TAG_FILE) mkdir -p ufo_3_models/ufo_3_SM cp $(UFO_MODELPATH)/SM/*.py ufo_3_models/ufo_3_SM +ufo_4_models/ufo_4_SM/$(UFO_TAG_FILE): $(UFO_MODELPATH)/SM/$(UFO_TAG_FILE) + mkdir -p ufo_4_models/ufo_4_SM + cp $(UFO_MODELPATH)/SM/*.py ufo_4_models/ufo_4_SM $(UFO_MODELPATH)/SM/$(UFO_TAG_FILE): $(top_srcdir)/omega/tests/UFO/SM/$(UFO_TAG_FILE) $(MAKE) -C $(UFO_MODELPATH)/SM all endif OCAML_AVAILABLE if MPOST_AVAILABLE $(TESTS_REQ_GAMELAN): gamelan.sty gamelan.sty: $(top_builddir)/src/gamelan/gamelan.sty cp $< $@ $(top_builddir)/src/gamelan/gamelan.sty: $(MAKE) -C $(top_builddir)/src/gamelan gamelan.sty endif noinst_PROGRAMS = if OCAML_AVAILABLE noinst_PROGRAMS += resonances_1_count resonances_1_count_SOURCES = resonances_1_count.f90 resonances_1.run: resonances_1_count noinst_PROGRAMS += resonances_2_count resonances_2_count_SOURCES = resonances_2_count.f90 resonances_2.run: resonances_2_count noinst_PROGRAMS += resonances_3_count resonances_3_count_SOURCES = resonances_3_count.f90 resonances_3.run: resonances_3_count noinst_PROGRAMS += resonances_4_count resonances_4_count_SOURCES = resonances_4_count.f90 resonances_4.run: resonances_4_count noinst_PROGRAMS += resonances_9_count resonances_9_count_SOURCES = resonances_9_count.f90 resonances_9.run: resonances_9_count noinst_PROGRAMS += resonances_10_count resonances_10_count_SOURCES = resonances_10_count.f90 resonances_10.run: resonances_10_count noinst_PROGRAMS += resonances_11_count resonances_11_count_SOURCES = resonances_11_count.f90 resonances_11.run: resonances_11_count noinst_PROGRAMS += epa_2_count epa_2_count_SOURCES = epa_2_count.f90 epa_2.run: epa_2_count noinst_PROGRAMS += isr_epa_1_count isr_epa_1_count_SOURCES = isr_epa_1_count.f90 isr_epa_1.run: isr_epa_1_count noinst_PROGRAMS += analyze_6_check analyze_6_check_SOURCES = analyze_6_check.f90 analyze_6.run: analyze_6_check endif if HEPMC_AVAILABLE TESTS_SRC += $(hepmc_6_rd_SOURCES) noinst_PROGRAMS += hepmc_6_rd if HEPMC_IS_VERSION3 hepmc_6_rd_SOURCES = hepmc3_6_rd.cpp else hepmc_6_rd_SOURCES = hepmc2_6_rd.cpp endif hepmc_6_rd_CXXFLAGS = $(HEPMC_INCLUDES) $(AM_CXXFLAGS) hepmc_6_rd_LDADD = $(LDFLAGS_HEPMC) hepmc_6.run: hepmc_6_rd endif if LCIO_AVAILABLE TESTS_SRC += $(lcio_rd_SOURCES) noinst_PROGRAMS += lcio_rd lcio_rd_SOURCES = lcio_rd.cpp lcio_rd_CXXFLAGS = $(LCIO_INCLUDES) $(AM_CXXFLAGS) lcio_rd_LDADD = $(LDFLAGS_LCIO) lcio_1.run: lcio_rd lcio_2.run: lcio_rd lcio_3.run: lcio_rd lcio_4.run: lcio_rd lcio_5.run: lcio_rd lcio_10.run: lcio_rd endif stdhep_4.run: stdhep_rd stdhep_5.run: stdhep_rd stdhep_6.run: stdhep_rd polarized_1.run: stdhep_rd tauola_1.run: stdhep_rd tauola_2.run: stdhep_rd stdhep_rd: $(top_builddir)/src/xdr/stdhep_rd cp $< $@ susyhit.in: $(top_builddir)/share/tests/functional_tests/susyhit.in cp $< $@ BUILT_SOURCES = \ TESTFLAG \ HEPMC2_FLAG \ HEPMC3_FLAG \ LCIO_FLAG \ FASTJET_FLAG \ LHAPDF5_FLAG \ LHAPDF6_FLAG \ GAMELAN_FLAG \ MPI_FLAG \ EVENT_ANALYSIS_FLAG \ OCAML_FLAG \ PYTHIA6_FLAG \ PYTHIA8_FLAG \ OPENLOOPS_FLAG \ RECOLA_FLAG \ GZIP_FLAG \ STATIC_FLAG \ ref-output # If this file is found in the working directory, WHIZARD # will use the paths for the uninstalled version (source/build tree), # otherwise it uses the installed version TESTFLAG: touch $@ FASTJET_FLAG: if FASTJET_AVAILABLE touch $@ endif HEPMC2_FLAG: if HEPMC2_AVAILABLE touch $@ endif HEPMC3_FLAG: if HEPMC3_AVAILABLE touch $@ endif LCIO_FLAG: if LCIO_AVAILABLE touch $@ endif LHAPDF5_FLAG: if LHAPDF5_AVAILABLE touch $@ endif LHAPDF6_FLAG: if LHAPDF6_AVAILABLE touch $@ endif GAMELAN_FLAG: if MPOST_AVAILABLE touch $@ endif MPI_FLAG: if FC_USE_MPI touch $@ endif OCAML_FLAG: if OCAML_AVAILABLE touch $@ endif PYTHIA6_FLAG: if PYTHIA6_AVAILABLE touch $@ endif PYTHIA8_FLAG: if PYTHIA8_AVAILABLE touch $@ endif OPENLOOPS_FLAG: if OPENLOOPS_AVAILABLE touch $@ endif RECOLA_FLAG: if RECOLA_AVAILABLE touch $@ endif EVENT_ANALYSIS_FLAG: if EVENT_ANALYSIS_AVAILABLE touch $@ endif GZIP_FLAG: if GZIP_AVAILABLE touch $@ endif STATIC_FLAG: if STATIC_AVAILABLE touch $@ endif # The reference output files are in the source directory. Copy them here. if FC_QUAD ref-output: $(top_srcdir)/share/tests/functional_tests/ref-output mkdir -p ref-output for f in $ # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## EXTRA_DIST = \ $(TESTSUITE_MACROS) $(TESTSUITES_M4) $(TESTSUITES_SIN) \ $(TESTSUITE_TOOLS) \ $(REF_OUTPUT_FILES) \ cascades2_lexer_1.fds \ cascades2_1.fds \ cascades2_2.fds \ functional_tests/structure_2_inc.sin functional_tests/testproc_3.phs \ functional_tests/user_cuts.f90 \ functional_tests/susyhit.in \ ext_tests_nmssm/nmssm.slha TESTSUITE_MACROS = testsuite.m4 TESTSUITE_TOOLS = \ check-debug-output.py \ check-debug-output-hadro.py \ check-hepmc-weights.py \ compare-integrals.py \ compare-integrals-multi.py \ compare-methods.py \ compare-histograms.py REF_OUTPUT_FILES = \ extra_integration_results.dat \ $(REF_OUTPUT_FILES_BASE) $(REF_OUTPUT_FILES_DOUBLE) \ $(REF_OUTPUT_FILES_PREC) $(REF_OUTPUT_FILES_EXT) \ $(REF_OUTPUT_FILES_QUAD) REF_OUTPUT_FILES_BASE = \ unit_tests/ref-output/analysis_1.ref \ unit_tests/ref-output/pdg_arrays_1.ref \ unit_tests/ref-output/pdg_arrays_2.ref \ unit_tests/ref-output/pdg_arrays_3.ref \ unit_tests/ref-output/pdg_arrays_4.ref \ unit_tests/ref-output/pdg_arrays_5.ref \ unit_tests/ref-output/expressions_1.ref \ unit_tests/ref-output/expressions_2.ref \ unit_tests/ref-output/expressions_3.ref \ unit_tests/ref-output/expressions_4.ref \ unit_tests/ref-output/su_algebra_1.ref \ unit_tests/ref-output/su_algebra_2.ref \ unit_tests/ref-output/su_algebra_3.ref \ unit_tests/ref-output/su_algebra_4.ref \ unit_tests/ref-output/bloch_vectors_1.ref \ unit_tests/ref-output/bloch_vectors_2.ref \ unit_tests/ref-output/bloch_vectors_3.ref \ unit_tests/ref-output/bloch_vectors_4.ref \ unit_tests/ref-output/bloch_vectors_5.ref \ unit_tests/ref-output/bloch_vectors_6.ref \ unit_tests/ref-output/bloch_vectors_7.ref \ unit_tests/ref-output/polarization_1.ref \ unit_tests/ref-output/polarization_2.ref \ unit_tests/ref-output/beam_1.ref \ unit_tests/ref-output/beam_2.ref \ unit_tests/ref-output/beam_3.ref \ unit_tests/ref-output/md5_1.ref \ unit_tests/ref-output/cputime_1.ref \ unit_tests/ref-output/cputime_2.ref \ unit_tests/ref-output/lexer_1.ref \ unit_tests/ref-output/parse_1.ref \ unit_tests/ref-output/color_1.ref \ unit_tests/ref-output/color_2.ref \ unit_tests/ref-output/os_interface_1.ref \ unit_tests/ref-output/evaluator_1.ref \ unit_tests/ref-output/evaluator_2.ref \ unit_tests/ref-output/evaluator_3.ref \ unit_tests/ref-output/evaluator_4.ref \ unit_tests/ref-output/format_1.ref \ unit_tests/ref-output/sorting_1.ref \ unit_tests/ref-output/grids_1.ref \ unit_tests/ref-output/grids_2.ref \ unit_tests/ref-output/grids_3.ref \ unit_tests/ref-output/grids_4.ref \ unit_tests/ref-output/grids_5.ref \ unit_tests/ref-output/solver_1.ref \ unit_tests/ref-output/state_matrix_1.ref \ unit_tests/ref-output/state_matrix_2.ref \ unit_tests/ref-output/state_matrix_3.ref \ unit_tests/ref-output/state_matrix_4.ref \ unit_tests/ref-output/state_matrix_5.ref \ unit_tests/ref-output/state_matrix_6.ref \ unit_tests/ref-output/state_matrix_7.ref \ unit_tests/ref-output/interaction_1.ref \ unit_tests/ref-output/xml_1.ref \ unit_tests/ref-output/xml_2.ref \ unit_tests/ref-output/xml_3.ref \ unit_tests/ref-output/xml_4.ref \ unit_tests/ref-output/sm_qcd_1.ref \ unit_tests/ref-output/sm_physics_1.ref \ unit_tests/ref-output/sm_physics_2.ref \ unit_tests/ref-output/models_1.ref \ unit_tests/ref-output/models_2.ref \ unit_tests/ref-output/models_3.ref \ unit_tests/ref-output/models_4.ref \ unit_tests/ref-output/models_5.ref \ unit_tests/ref-output/models_6.ref \ unit_tests/ref-output/models_7.ref \ unit_tests/ref-output/models_8.ref \ unit_tests/ref-output/models_9.ref \ unit_tests/ref-output/auto_components_1.ref \ unit_tests/ref-output/auto_components_2.ref \ unit_tests/ref-output/auto_components_3.ref \ unit_tests/ref-output/radiation_generator_1.ref \ unit_tests/ref-output/radiation_generator_2.ref \ unit_tests/ref-output/radiation_generator_3.ref \ unit_tests/ref-output/radiation_generator_4.ref \ unit_tests/ref-output/particles_1.ref \ unit_tests/ref-output/particles_2.ref \ unit_tests/ref-output/particles_3.ref \ unit_tests/ref-output/particles_4.ref \ unit_tests/ref-output/particles_5.ref \ unit_tests/ref-output/particles_6.ref \ unit_tests/ref-output/particles_7.ref \ unit_tests/ref-output/particles_8.ref \ unit_tests/ref-output/particles_9.ref \ unit_tests/ref-output/beam_structures_1.ref \ unit_tests/ref-output/beam_structures_2.ref \ unit_tests/ref-output/beam_structures_3.ref \ unit_tests/ref-output/beam_structures_4.ref \ unit_tests/ref-output/beam_structures_5.ref \ unit_tests/ref-output/beam_structures_6.ref \ unit_tests/ref-output/sf_aux_1.ref \ unit_tests/ref-output/sf_aux_2.ref \ unit_tests/ref-output/sf_aux_3.ref \ unit_tests/ref-output/sf_aux_4.ref \ unit_tests/ref-output/sf_mappings_1.ref \ unit_tests/ref-output/sf_mappings_2.ref \ unit_tests/ref-output/sf_mappings_3.ref \ unit_tests/ref-output/sf_mappings_4.ref \ unit_tests/ref-output/sf_mappings_5.ref \ unit_tests/ref-output/sf_mappings_6.ref \ unit_tests/ref-output/sf_mappings_7.ref \ unit_tests/ref-output/sf_mappings_8.ref \ unit_tests/ref-output/sf_mappings_9.ref \ unit_tests/ref-output/sf_mappings_10.ref \ unit_tests/ref-output/sf_mappings_11.ref \ unit_tests/ref-output/sf_mappings_12.ref \ unit_tests/ref-output/sf_mappings_13.ref \ unit_tests/ref-output/sf_mappings_14.ref \ unit_tests/ref-output/sf_mappings_15.ref \ unit_tests/ref-output/sf_mappings_16.ref \ unit_tests/ref-output/sf_base_1.ref \ unit_tests/ref-output/sf_base_2.ref \ unit_tests/ref-output/sf_base_3.ref \ unit_tests/ref-output/sf_base_4.ref \ unit_tests/ref-output/sf_base_5.ref \ unit_tests/ref-output/sf_base_6.ref \ unit_tests/ref-output/sf_base_7.ref \ unit_tests/ref-output/sf_base_8.ref \ unit_tests/ref-output/sf_base_9.ref \ unit_tests/ref-output/sf_base_10.ref \ unit_tests/ref-output/sf_base_11.ref \ unit_tests/ref-output/sf_base_12.ref \ unit_tests/ref-output/sf_base_13.ref \ unit_tests/ref-output/sf_base_14.ref \ unit_tests/ref-output/sf_pdf_builtin_1.ref \ unit_tests/ref-output/sf_pdf_builtin_2.ref \ unit_tests/ref-output/sf_pdf_builtin_3.ref \ unit_tests/ref-output/sf_lhapdf5_1.ref \ unit_tests/ref-output/sf_lhapdf5_2.ref \ unit_tests/ref-output/sf_lhapdf5_3.ref \ unit_tests/ref-output/sf_lhapdf6_1.ref \ unit_tests/ref-output/sf_lhapdf6_2.ref \ unit_tests/ref-output/sf_lhapdf6_3.ref \ unit_tests/ref-output/sf_isr_1.ref \ unit_tests/ref-output/sf_isr_2.ref \ unit_tests/ref-output/sf_isr_3.ref \ unit_tests/ref-output/sf_isr_4.ref \ unit_tests/ref-output/sf_isr_5.ref \ unit_tests/ref-output/sf_epa_1.ref \ unit_tests/ref-output/sf_epa_2.ref \ unit_tests/ref-output/sf_epa_3.ref \ unit_tests/ref-output/sf_epa_4.ref \ unit_tests/ref-output/sf_epa_5.ref \ unit_tests/ref-output/sf_ewa_1.ref \ unit_tests/ref-output/sf_ewa_2.ref \ unit_tests/ref-output/sf_ewa_3.ref \ unit_tests/ref-output/sf_ewa_4.ref \ unit_tests/ref-output/sf_ewa_5.ref \ unit_tests/ref-output/sf_circe1_1.ref \ unit_tests/ref-output/sf_circe1_2.ref \ unit_tests/ref-output/sf_circe1_3.ref \ unit_tests/ref-output/sf_circe2_1.ref \ unit_tests/ref-output/sf_circe2_2.ref \ unit_tests/ref-output/sf_circe2_3.ref \ unit_tests/ref-output/sf_gaussian_1.ref \ unit_tests/ref-output/sf_gaussian_2.ref \ unit_tests/ref-output/sf_beam_events_1.ref \ unit_tests/ref-output/sf_beam_events_2.ref \ unit_tests/ref-output/sf_beam_events_3.ref \ unit_tests/ref-output/sf_escan_1.ref \ unit_tests/ref-output/sf_escan_2.ref \ unit_tests/ref-output/phs_base_1.ref \ unit_tests/ref-output/phs_base_2.ref \ unit_tests/ref-output/phs_base_3.ref \ unit_tests/ref-output/phs_base_4.ref \ unit_tests/ref-output/phs_base_5.ref \ unit_tests/ref-output/phs_none_1.ref \ unit_tests/ref-output/phs_single_1.ref \ unit_tests/ref-output/phs_single_2.ref \ unit_tests/ref-output/phs_single_3.ref \ unit_tests/ref-output/phs_single_4.ref \ unit_tests/ref-output/phs_rambo_1.ref \ unit_tests/ref-output/phs_rambo_2.ref \ unit_tests/ref-output/phs_rambo_3.ref \ unit_tests/ref-output/phs_rambo_4.ref \ unit_tests/ref-output/resonances_1.ref \ unit_tests/ref-output/resonances_2.ref \ unit_tests/ref-output/resonances_3.ref \ unit_tests/ref-output/resonances_4.ref \ unit_tests/ref-output/resonances_5.ref \ unit_tests/ref-output/resonances_6.ref \ unit_tests/ref-output/resonances_7.ref \ unit_tests/ref-output/phs_tree_1.ref \ unit_tests/ref-output/phs_tree_2.ref \ unit_tests/ref-output/phs_forest_1.ref \ unit_tests/ref-output/phs_forest_2.ref \ unit_tests/ref-output/phs_wood_1.ref \ unit_tests/ref-output/phs_wood_2.ref \ unit_tests/ref-output/phs_wood_3.ref \ unit_tests/ref-output/phs_wood_4.ref \ unit_tests/ref-output/phs_wood_5.ref \ unit_tests/ref-output/phs_wood_6.ref \ unit_tests/ref-output/phs_wood_vis_1.ref \ unit_tests/ref-output/phs_fks_generator_1.ref \ unit_tests/ref-output/phs_fks_generator_2.ref \ unit_tests/ref-output/phs_fks_generator_3.ref \ unit_tests/ref-output/phs_fks_generator_4.ref \ unit_tests/ref-output/phs_fks_generator_5.ref \ unit_tests/ref-output/phs_fks_generator_6.ref \ unit_tests/ref-output/phs_fks_generator_7.ref \ unit_tests/ref-output/fks_regions_1.ref \ unit_tests/ref-output/fks_regions_2.ref \ unit_tests/ref-output/fks_regions_3.ref \ unit_tests/ref-output/fks_regions_4.ref \ unit_tests/ref-output/fks_regions_5.ref \ unit_tests/ref-output/fks_regions_6.ref \ unit_tests/ref-output/fks_regions_7.ref \ unit_tests/ref-output/fks_regions_8.ref \ unit_tests/ref-output/real_subtraction_1.ref \ unit_tests/ref-output/prc_recola_1.ref \ unit_tests/ref-output/prc_recola_2.ref \ unit_tests/ref-output/rng_base_1.ref \ unit_tests/ref-output/rng_base_2.ref \ unit_tests/ref-output/rng_tao_1.ref \ unit_tests/ref-output/rng_tao_2.ref \ unit_tests/ref-output/rng_stream_1.ref \ unit_tests/ref-output/rng_stream_2.ref \ unit_tests/ref-output/rng_stream_3.ref \ unit_tests/ref-output/selectors_1.ref \ unit_tests/ref-output/selectors_2.ref \ unit_tests/ref-output/vegas_1.ref \ unit_tests/ref-output/vegas_2.ref \ unit_tests/ref-output/vegas_3.ref \ unit_tests/ref-output/vegas_4.ref \ unit_tests/ref-output/vegas_5.ref \ unit_tests/ref-output/vegas_6.ref \ unit_tests/ref-output/vamp2_1.ref \ unit_tests/ref-output/vamp2_2.ref \ unit_tests/ref-output/vamp2_3.ref \ unit_tests/ref-output/vamp2_4.ref \ unit_tests/ref-output/vamp2_5.ref \ unit_tests/ref-output/mci_base_1.ref \ unit_tests/ref-output/mci_base_2.ref \ unit_tests/ref-output/mci_base_3.ref \ unit_tests/ref-output/mci_base_4.ref \ unit_tests/ref-output/mci_base_5.ref \ unit_tests/ref-output/mci_base_6.ref \ unit_tests/ref-output/mci_base_7.ref \ unit_tests/ref-output/mci_base_8.ref \ unit_tests/ref-output/mci_none_1.ref \ unit_tests/ref-output/mci_midpoint_1.ref \ unit_tests/ref-output/mci_midpoint_2.ref \ unit_tests/ref-output/mci_midpoint_3.ref \ unit_tests/ref-output/mci_midpoint_4.ref \ unit_tests/ref-output/mci_midpoint_5.ref \ unit_tests/ref-output/mci_midpoint_6.ref \ unit_tests/ref-output/mci_midpoint_7.ref \ unit_tests/ref-output/mci_vamp_1.ref \ unit_tests/ref-output/mci_vamp_2.ref \ unit_tests/ref-output/mci_vamp_3.ref \ unit_tests/ref-output/mci_vamp_4.ref \ unit_tests/ref-output/mci_vamp_5.ref \ unit_tests/ref-output/mci_vamp_6.ref \ unit_tests/ref-output/mci_vamp_7.ref \ unit_tests/ref-output/mci_vamp_8.ref \ unit_tests/ref-output/mci_vamp_9.ref \ unit_tests/ref-output/mci_vamp_10.ref \ unit_tests/ref-output/mci_vamp_11.ref \ unit_tests/ref-output/mci_vamp_12.ref \ unit_tests/ref-output/mci_vamp_13.ref \ unit_tests/ref-output/mci_vamp_14.ref \ unit_tests/ref-output/mci_vamp_15.ref \ unit_tests/ref-output/mci_vamp_16.ref \ unit_tests/ref-output/mci_vamp2_1.ref \ unit_tests/ref-output/mci_vamp2_2.ref \ unit_tests/ref-output/mci_vamp2_3.ref \ unit_tests/ref-output/integration_results_1.ref \ unit_tests/ref-output/integration_results_2.ref \ unit_tests/ref-output/integration_results_3.ref \ unit_tests/ref-output/integration_results_4.ref \ unit_tests/ref-output/integration_results_5.ref \ unit_tests/ref-output/prclib_interfaces_1.ref \ unit_tests/ref-output/prclib_interfaces_2.ref \ unit_tests/ref-output/prclib_interfaces_3.ref \ unit_tests/ref-output/prclib_interfaces_4.ref \ unit_tests/ref-output/prclib_interfaces_5.ref \ unit_tests/ref-output/prclib_interfaces_6.ref \ unit_tests/ref-output/prclib_interfaces_7.ref \ unit_tests/ref-output/particle_specifiers_1.ref \ unit_tests/ref-output/particle_specifiers_2.ref \ unit_tests/ref-output/process_libraries_1.ref \ unit_tests/ref-output/process_libraries_2.ref \ unit_tests/ref-output/process_libraries_3.ref \ unit_tests/ref-output/process_libraries_4.ref \ unit_tests/ref-output/process_libraries_5.ref \ unit_tests/ref-output/process_libraries_6.ref \ unit_tests/ref-output/process_libraries_7.ref \ unit_tests/ref-output/process_libraries_8.ref \ unit_tests/ref-output/prclib_stacks_1.ref \ unit_tests/ref-output/prclib_stacks_2.ref \ unit_tests/ref-output/slha_1.ref \ unit_tests/ref-output/slha_2.ref \ unit_tests/ref-output/prc_test_1.ref \ unit_tests/ref-output/prc_test_2.ref \ unit_tests/ref-output/prc_test_3.ref \ unit_tests/ref-output/prc_test_4.ref \ unit_tests/ref-output/prc_template_me_1.ref \ unit_tests/ref-output/prc_template_me_2.ref \ unit_tests/ref-output/prc_omega_1.ref \ unit_tests/ref-output/prc_omega_2.ref \ unit_tests/ref-output/prc_omega_3.ref \ unit_tests/ref-output/prc_omega_4.ref \ unit_tests/ref-output/prc_omega_5.ref \ unit_tests/ref-output/prc_omega_6.ref \ unit_tests/ref-output/prc_omega_diags_1.ref \ unit_tests/ref-output/parton_states_1.ref \ unit_tests/ref-output/subevt_expr_1.ref \ unit_tests/ref-output/subevt_expr_2.ref \ unit_tests/ref-output/processes_1.ref \ unit_tests/ref-output/processes_2.ref \ unit_tests/ref-output/processes_3.ref \ unit_tests/ref-output/processes_4.ref \ unit_tests/ref-output/processes_5.ref \ unit_tests/ref-output/processes_6.ref \ unit_tests/ref-output/processes_7.ref \ unit_tests/ref-output/processes_8.ref \ unit_tests/ref-output/processes_9.ref \ unit_tests/ref-output/processes_10.ref \ unit_tests/ref-output/processes_11.ref \ unit_tests/ref-output/processes_12.ref \ unit_tests/ref-output/processes_13.ref \ unit_tests/ref-output/processes_14.ref \ unit_tests/ref-output/processes_15.ref \ unit_tests/ref-output/processes_16.ref \ unit_tests/ref-output/processes_17.ref \ unit_tests/ref-output/processes_18.ref \ unit_tests/ref-output/processes_19.ref \ unit_tests/ref-output/process_stacks_1.ref \ unit_tests/ref-output/process_stacks_2.ref \ unit_tests/ref-output/process_stacks_3.ref \ unit_tests/ref-output/process_stacks_4.ref \ unit_tests/ref-output/cascades_1.ref \ unit_tests/ref-output/cascades_2.ref \ unit_tests/ref-output/cascades2_lexer_1.ref \ unit_tests/ref-output/cascades2_1.ref \ unit_tests/ref-output/cascades2_2.ref \ unit_tests/ref-output/event_transforms_1.ref \ unit_tests/ref-output/recoil_kinematics_1.ref \ unit_tests/ref-output/recoil_kinematics_2.ref \ unit_tests/ref-output/recoil_kinematics_3.ref \ unit_tests/ref-output/recoil_kinematics_4.ref \ unit_tests/ref-output/recoil_kinematics_5.ref \ unit_tests/ref-output/resonance_insertion_1.ref \ unit_tests/ref-output/resonance_insertion_2.ref \ unit_tests/ref-output/resonance_insertion_3.ref \ unit_tests/ref-output/resonance_insertion_4.ref \ unit_tests/ref-output/resonance_insertion_5.ref \ unit_tests/ref-output/resonance_insertion_6.ref \ unit_tests/ref-output/isr_handler_1.ref \ unit_tests/ref-output/isr_handler_2.ref \ unit_tests/ref-output/isr_handler_3.ref \ unit_tests/ref-output/epa_handler_1.ref \ unit_tests/ref-output/epa_handler_2.ref \ unit_tests/ref-output/epa_handler_3.ref \ unit_tests/ref-output/decays_1.ref \ unit_tests/ref-output/decays_2.ref \ unit_tests/ref-output/decays_3.ref \ unit_tests/ref-output/decays_4.ref \ unit_tests/ref-output/decays_5.ref \ unit_tests/ref-output/decays_6.ref \ unit_tests/ref-output/shower_1.ref \ unit_tests/ref-output/shower_2.ref \ unit_tests/ref-output/shower_base_1.ref \ unit_tests/ref-output/events_1.ref \ unit_tests/ref-output/events_2.ref \ unit_tests/ref-output/events_3.ref \ unit_tests/ref-output/events_4.ref \ unit_tests/ref-output/events_5.ref \ unit_tests/ref-output/events_6.ref \ unit_tests/ref-output/events_7.ref \ unit_tests/ref-output/hep_events_1.ref \ unit_tests/ref-output/eio_data_1.ref \ unit_tests/ref-output/eio_data_2.ref \ unit_tests/ref-output/eio_base_1.ref \ unit_tests/ref-output/eio_direct_1.ref \ unit_tests/ref-output/eio_raw_1.ref \ unit_tests/ref-output/eio_raw_2.ref \ unit_tests/ref-output/eio_checkpoints_1.ref \ unit_tests/ref-output/eio_lhef_1.ref \ unit_tests/ref-output/eio_lhef_2.ref \ unit_tests/ref-output/eio_lhef_3.ref \ unit_tests/ref-output/eio_lhef_4.ref \ unit_tests/ref-output/eio_lhef_5.ref \ unit_tests/ref-output/eio_lhef_6.ref \ unit_tests/ref-output/eio_stdhep_1.ref \ unit_tests/ref-output/eio_stdhep_2.ref \ unit_tests/ref-output/eio_stdhep_3.ref \ unit_tests/ref-output/eio_stdhep_4.ref \ unit_tests/ref-output/eio_hepmc2_1.ref \ unit_tests/ref-output/eio_hepmc2_2.ref \ unit_tests/ref-output/eio_hepmc3_1.ref \ unit_tests/ref-output/eio_hepmc3_2.ref \ unit_tests/ref-output/eio_lcio_1.ref \ unit_tests/ref-output/eio_lcio_2.ref \ unit_tests/ref-output/eio_ascii_1.ref \ unit_tests/ref-output/eio_ascii_2.ref \ unit_tests/ref-output/eio_ascii_3.ref \ unit_tests/ref-output/eio_ascii_4.ref \ unit_tests/ref-output/eio_ascii_5.ref \ unit_tests/ref-output/eio_ascii_6.ref \ unit_tests/ref-output/eio_ascii_7.ref \ unit_tests/ref-output/eio_ascii_8.ref \ unit_tests/ref-output/eio_ascii_9.ref \ unit_tests/ref-output/eio_ascii_10.ref \ unit_tests/ref-output/eio_weights_1.ref \ unit_tests/ref-output/eio_weights_2.ref \ unit_tests/ref-output/eio_weights_3.ref \ unit_tests/ref-output/eio_dump_1.ref \ unit_tests/ref-output/iterations_1.ref \ unit_tests/ref-output/iterations_2.ref \ unit_tests/ref-output/rt_data_1.ref \ unit_tests/ref-output/rt_data_2.ref \ unit_tests/ref-output/rt_data_3.ref \ unit_tests/ref-output/rt_data_4.ref \ unit_tests/ref-output/rt_data_5.ref \ unit_tests/ref-output/rt_data_6.ref \ unit_tests/ref-output/rt_data_7.ref \ unit_tests/ref-output/rt_data_8.ref \ unit_tests/ref-output/rt_data_9.ref \ unit_tests/ref-output/rt_data_10.ref \ unit_tests/ref-output/rt_data_11.ref \ unit_tests/ref-output/dispatch_1.ref \ unit_tests/ref-output/dispatch_2.ref \ unit_tests/ref-output/dispatch_7.ref \ unit_tests/ref-output/dispatch_8.ref \ unit_tests/ref-output/dispatch_10.ref \ unit_tests/ref-output/dispatch_11.ref \ unit_tests/ref-output/dispatch_rng_1.ref \ unit_tests/ref-output/dispatch_phs_1.ref \ unit_tests/ref-output/dispatch_phs_2.ref \ unit_tests/ref-output/dispatch_mci_1.ref \ unit_tests/ref-output/dispatch_transforms_1.ref \ unit_tests/ref-output/dispatch_transforms_2.ref \ unit_tests/ref-output/process_configurations_1.ref \ unit_tests/ref-output/process_configurations_2.ref \ unit_tests/ref-output/event_streams_1.ref \ unit_tests/ref-output/event_streams_2.ref \ unit_tests/ref-output/event_streams_3.ref \ unit_tests/ref-output/event_streams_4.ref \ unit_tests/ref-output/compilations_1.ref \ unit_tests/ref-output/compilations_2.ref \ unit_tests/ref-output/compilations_3.ref \ unit_tests/ref-output/compilations_static_1.ref \ unit_tests/ref-output/compilations_static_2.ref \ unit_tests/ref-output/integrations_1.ref \ unit_tests/ref-output/integrations_2.ref \ unit_tests/ref-output/integrations_3.ref \ unit_tests/ref-output/integrations_4.ref \ unit_tests/ref-output/integrations_5.ref \ unit_tests/ref-output/integrations_6.ref \ unit_tests/ref-output/integrations_7.ref \ unit_tests/ref-output/integrations_8.ref \ unit_tests/ref-output/integrations_9.ref \ unit_tests/ref-output/integrations_history_1.ref \ unit_tests/ref-output/restricted_subprocesses_1.ref \ unit_tests/ref-output/restricted_subprocesses_2.ref \ unit_tests/ref-output/restricted_subprocesses_3.ref \ unit_tests/ref-output/restricted_subprocesses_4.ref \ unit_tests/ref-output/restricted_subprocesses_5.ref \ unit_tests/ref-output/restricted_subprocesses_6.ref \ unit_tests/ref-output/simulations_1.ref \ unit_tests/ref-output/simulations_2.ref \ unit_tests/ref-output/simulations_3.ref \ unit_tests/ref-output/simulations_4.ref \ unit_tests/ref-output/simulations_5.ref \ unit_tests/ref-output/simulations_6.ref \ unit_tests/ref-output/simulations_7.ref \ unit_tests/ref-output/simulations_8.ref \ unit_tests/ref-output/simulations_9.ref \ unit_tests/ref-output/simulations_10.ref \ unit_tests/ref-output/simulations_11.ref \ unit_tests/ref-output/simulations_12.ref \ unit_tests/ref-output/simulations_13.ref \ unit_tests/ref-output/simulations_14.ref \ unit_tests/ref-output/simulations_15.ref \ unit_tests/ref-output/commands_1.ref \ unit_tests/ref-output/commands_2.ref \ unit_tests/ref-output/commands_3.ref \ unit_tests/ref-output/commands_4.ref \ unit_tests/ref-output/commands_5.ref \ unit_tests/ref-output/commands_6.ref \ unit_tests/ref-output/commands_7.ref \ unit_tests/ref-output/commands_8.ref \ unit_tests/ref-output/commands_9.ref \ unit_tests/ref-output/commands_10.ref \ unit_tests/ref-output/commands_11.ref \ unit_tests/ref-output/commands_12.ref \ unit_tests/ref-output/commands_13.ref \ unit_tests/ref-output/commands_14.ref \ unit_tests/ref-output/commands_15.ref \ unit_tests/ref-output/commands_16.ref \ unit_tests/ref-output/commands_17.ref \ unit_tests/ref-output/commands_18.ref \ unit_tests/ref-output/commands_19.ref \ unit_tests/ref-output/commands_20.ref \ unit_tests/ref-output/commands_21.ref \ unit_tests/ref-output/commands_22.ref \ unit_tests/ref-output/commands_23.ref \ unit_tests/ref-output/commands_24.ref \ unit_tests/ref-output/commands_25.ref \ unit_tests/ref-output/commands_26.ref \ unit_tests/ref-output/commands_27.ref \ unit_tests/ref-output/commands_28.ref \ unit_tests/ref-output/commands_29.ref \ unit_tests/ref-output/commands_30.ref \ unit_tests/ref-output/commands_31.ref \ unit_tests/ref-output/commands_32.ref \ unit_tests/ref-output/commands_33.ref \ unit_tests/ref-output/commands_34.ref \ unit_tests/ref-output/jets_1.ref \ unit_tests/ref-output/hepmc2_interface_1.ref \ unit_tests/ref-output/hepmc3_interface_1.ref \ unit_tests/ref-output/lcio_interface_1.ref \ unit_tests/ref-output/ttv_formfactors_1.ref \ unit_tests/ref-output/ttv_formfactors_2.ref \ unit_tests/ref-output/blha_1.ref \ unit_tests/ref-output/blha_2.ref \ unit_tests/ref-output/blha_3.ref \ unit_tests/ref-output/whizard_lha_1.ref \ functional_tests/ref-output/pack_1.ref \ functional_tests/ref-output/structure_1.ref \ functional_tests/ref-output/structure_2.ref \ functional_tests/ref-output/structure_3.ref \ functional_tests/ref-output/structure_4.ref \ functional_tests/ref-output/structure_5.ref \ functional_tests/ref-output/structure_6.ref \ functional_tests/ref-output/structure_7.ref \ functional_tests/ref-output/structure_8.ref \ functional_tests/ref-output/vars.ref \ functional_tests/ref-output/extpar.ref \ functional_tests/ref-output/testproc_1.ref \ functional_tests/ref-output/testproc_2.ref \ functional_tests/ref-output/testproc_3.ref \ functional_tests/ref-output/testproc_4.ref \ functional_tests/ref-output/testproc_5.ref \ functional_tests/ref-output/testproc_6.ref \ functional_tests/ref-output/testproc_7.ref \ functional_tests/ref-output/testproc_8.ref \ functional_tests/ref-output/testproc_9.ref \ functional_tests/ref-output/testproc_10.ref \ functional_tests/ref-output/testproc_11.ref \ functional_tests/ref-output/testproc_12.ref \ functional_tests/ref-output/template_me_1.ref \ functional_tests/ref-output/template_me_2.ref \ functional_tests/ref-output/susyhit.ref \ functional_tests/ref-output/restrictions.ref \ functional_tests/ref-output/process_log.ref \ functional_tests/ref-output/static_1.ref \ functional_tests/ref-output/static_2.ref \ functional_tests/ref-output/libraries_1.ref \ functional_tests/ref-output/libraries_2.ref \ functional_tests/ref-output/libraries_4.ref \ functional_tests/ref-output/job_id_1.ref \ functional_tests/ref-output/job_id_2.ref \ functional_tests/ref-output/job_id_3.ref \ functional_tests/ref-output/job_id_4.ref \ functional_tests/ref-output/rebuild_2.ref \ functional_tests/ref-output/rebuild_3.ref \ functional_tests/ref-output/rebuild_4.ref \ functional_tests/ref-output/fatal.ref \ functional_tests/ref-output/model_change_1.ref \ functional_tests/ref-output/model_change_2.ref \ functional_tests/ref-output/model_change_3.ref \ functional_tests/ref-output/model_scheme_1.ref \ functional_tests/ref-output/model_test.ref \ functional_tests/ref-output/cuts.ref \ functional_tests/ref-output/user_cuts.ref \ functional_tests/ref-output/user_prc_threshold_1.ref \ functional_tests/ref-output/user_prc_threshold_2.ref \ functional_tests/ref-output/qedtest_1.ref \ functional_tests/ref-output/qedtest_2.ref \ functional_tests/ref-output/qedtest_5.ref \ functional_tests/ref-output/qedtest_6.ref \ functional_tests/ref-output/qedtest_7.ref \ functional_tests/ref-output/qedtest_8.ref \ functional_tests/ref-output/qedtest_9.ref \ functional_tests/ref-output/qedtest_10.ref \ functional_tests/ref-output/qcdtest_4.ref \ functional_tests/ref-output/qcdtest_5.ref \ functional_tests/ref-output/qcdtest_6.ref \ functional_tests/ref-output/rambo_vamp_1.ref \ functional_tests/ref-output/rambo_vamp_2.ref \ functional_tests/ref-output/beam_setup_1.ref \ functional_tests/ref-output/beam_setup_2.ref \ functional_tests/ref-output/beam_setup_3.ref \ functional_tests/ref-output/beam_setup_4.ref \ functional_tests/ref-output/observables_1.ref \ functional_tests/ref-output/event_weights_1.ref \ functional_tests/ref-output/event_weights_2.ref \ functional_tests/ref-output/event_eff_1.ref \ functional_tests/ref-output/event_eff_2.ref \ functional_tests/ref-output/event_dump_1.ref \ functional_tests/ref-output/event_dump_2.ref \ functional_tests/ref-output/reweight_1.ref \ functional_tests/ref-output/reweight_2.ref \ functional_tests/ref-output/reweight_3.ref \ functional_tests/ref-output/reweight_4.ref \ functional_tests/ref-output/reweight_5.ref \ functional_tests/ref-output/reweight_6.ref \ functional_tests/ref-output/reweight_7.ref \ functional_tests/ref-output/reweight_8.ref \ functional_tests/ref-output/analyze_1.ref \ functional_tests/ref-output/analyze_2.ref \ functional_tests/ref-output/analyze_3.ref \ functional_tests/ref-output/analyze_4.ref \ functional_tests/ref-output/analyze_5.ref \ functional_tests/ref-output/analyze_6.ref \ functional_tests/ref-output/bjet_cluster.ref \ functional_tests/ref-output/colors.ref \ functional_tests/ref-output/colors_hgg.ref \ functional_tests/ref-output/alphas.ref \ functional_tests/ref-output/jets_xsec.ref \ functional_tests/ref-output/shower_err_1.ref \ functional_tests/ref-output/parton_shower_1.ref \ functional_tests/ref-output/pythia6_1.ref \ functional_tests/ref-output/pythia6_2.ref \ functional_tests/ref-output/hadronize_1.ref \ functional_tests/ref-output/mlm_matching_fsr.ref \ functional_tests/ref-output/mlm_pythia6_isr.ref \ functional_tests/ref-output/hepmc_1.ref \ functional_tests/ref-output/hepmc_2.ref \ functional_tests/ref-output/hepmc_3.ref \ functional_tests/ref-output/hepmc_4.ref \ functional_tests/ref-output/hepmc_5.ref \ functional_tests/ref-output/hepmc_6.ref \ functional_tests/ref-output/hepmc_7.ref \ functional_tests/ref-output/hepmc_9.ref \ functional_tests/ref-output/hepmc_10.ref \ functional_tests/ref-output/lhef_1.ref \ functional_tests/ref-output/lhef_2.ref \ functional_tests/ref-output/lhef_3.ref \ functional_tests/ref-output/lhef_4.ref \ functional_tests/ref-output/lhef_5.ref \ functional_tests/ref-output/lhef_6.ref \ functional_tests/ref-output/lhef_9.ref \ functional_tests/ref-output/lhef_10.ref \ functional_tests/ref-output/lhef_11.ref \ functional_tests/ref-output/select_1.ref \ functional_tests/ref-output/select_2.ref \ functional_tests/ref-output/stdhep_1.ref \ functional_tests/ref-output/stdhep_2.ref \ functional_tests/ref-output/stdhep_3.ref \ functional_tests/ref-output/stdhep_4.ref \ functional_tests/ref-output/stdhep_5.ref \ functional_tests/ref-output/stdhep_6.ref \ functional_tests/ref-output/lcio_1.ref \ functional_tests/ref-output/lcio_3.ref \ functional_tests/ref-output/lcio_4.ref \ functional_tests/ref-output/lcio_5.ref \ functional_tests/ref-output/lcio_6.ref \ functional_tests/ref-output/lcio_8.ref \ functional_tests/ref-output/lcio_9.ref \ functional_tests/ref-output/lcio_10.ref \ functional_tests/ref-output/fatal_beam_decay.ref \ functional_tests/ref-output/smtest_1.ref \ functional_tests/ref-output/smtest_3.ref \ functional_tests/ref-output/smtest_4.ref \ functional_tests/ref-output/smtest_5.ref \ functional_tests/ref-output/smtest_6.ref \ functional_tests/ref-output/smtest_7.ref \ functional_tests/ref-output/smtest_9.ref \ functional_tests/ref-output/smtest_10.ref \ functional_tests/ref-output/smtest_11.ref \ functional_tests/ref-output/smtest_12.ref \ functional_tests/ref-output/smtest_13.ref \ functional_tests/ref-output/smtest_14.ref \ functional_tests/ref-output/smtest_15.ref \ functional_tests/ref-output/smtest_16.ref \ functional_tests/ref-output/photon_isolation_1.ref \ functional_tests/ref-output/photon_isolation_2.ref \ functional_tests/ref-output/sm_cms_1.ref \ functional_tests/ref-output/resonances_5.ref \ functional_tests/ref-output/resonances_6.ref \ functional_tests/ref-output/resonances_7.ref \ functional_tests/ref-output/resonances_8.ref \ functional_tests/ref-output/resonances_9.ref \ functional_tests/ref-output/resonances_12.ref \ functional_tests/ref-output/ufo_1.ref \ functional_tests/ref-output/ufo_2.ref \ functional_tests/ref-output/ufo_3.ref \ + functional_tests/ref-output/ufo_4.ref \ functional_tests/ref-output/nlo_1.ref \ functional_tests/ref-output/nlo_2.ref \ functional_tests/ref-output/nlo_6.ref \ functional_tests/ref-output/real_partition_1.ref \ functional_tests/ref-output/fks_res_2.ref \ functional_tests/ref-output/openloops_1.ref \ functional_tests/ref-output/openloops_2.ref \ functional_tests/ref-output/openloops_4.ref \ functional_tests/ref-output/openloops_5.ref \ functional_tests/ref-output/openloops_6.ref \ functional_tests/ref-output/openloops_7.ref \ functional_tests/ref-output/openloops_8.ref \ functional_tests/ref-output/openloops_9.ref \ functional_tests/ref-output/openloops_10.ref \ functional_tests/ref-output/openloops_11.ref \ functional_tests/ref-output/openloops_12.ref \ functional_tests/ref-output/openloops_13.ref \ functional_tests/ref-output/recola_1.ref \ functional_tests/ref-output/recola_2.ref \ functional_tests/ref-output/recola_3.ref \ functional_tests/ref-output/recola_4.ref \ functional_tests/ref-output/recola_5.ref \ functional_tests/ref-output/recola_6.ref \ functional_tests/ref-output/recola_7.ref \ functional_tests/ref-output/recola_8.ref \ functional_tests/ref-output/nlo_decay_1.ref \ functional_tests/ref-output/mssmtest_1.ref \ functional_tests/ref-output/mssmtest_2.ref \ functional_tests/ref-output/mssmtest_3.ref \ functional_tests/ref-output/spincor_1.ref \ functional_tests/ref-output/show_1.ref \ functional_tests/ref-output/show_2.ref \ functional_tests/ref-output/show_3.ref \ functional_tests/ref-output/show_4.ref \ functional_tests/ref-output/show_5.ref \ functional_tests/ref-output/method_ovm_1.ref \ functional_tests/ref-output/multi_comp_4.ref \ functional_tests/ref-output/flvsum_1.ref \ functional_tests/ref-output/br_redef_1.ref \ functional_tests/ref-output/decay_err_1.ref \ functional_tests/ref-output/decay_err_2.ref \ functional_tests/ref-output/decay_err_3.ref \ functional_tests/ref-output/polarized_1.ref \ functional_tests/ref-output/circe1_1.ref \ functional_tests/ref-output/circe1_2.ref \ functional_tests/ref-output/circe1_3.ref \ functional_tests/ref-output/circe1_6.ref \ functional_tests/ref-output/circe1_10.ref \ functional_tests/ref-output/circe1_errors_1.ref \ functional_tests/ref-output/circe2_1.ref \ functional_tests/ref-output/circe2_2.ref \ functional_tests/ref-output/circe2_3.ref \ functional_tests/ref-output/isr_1.ref \ functional_tests/ref-output/epa_1.ref \ functional_tests/ref-output/epa_2.ref \ functional_tests/ref-output/isr_epa_1.ref \ functional_tests/ref-output/ep_3.ref \ functional_tests/ref-output/ewa_4.ref \ functional_tests/ref-output/gaussian_1.ref \ functional_tests/ref-output/gaussian_2.ref \ functional_tests/ref-output/beam_events_1.ref \ functional_tests/ref-output/beam_events_4.ref \ functional_tests/ref-output/energy_scan_1.ref \ functional_tests/ref-output/cascades2_phs_1.ref \ functional_tests/ref-output/vamp2_1.ref \ functional_tests/ref-output/vamp2_2.ref \ ext_tests_nlo/ref-output/nlo_ee4j.ref \ ext_tests_nlo/ref-output/nlo_ee4t.ref \ ext_tests_nlo/ref-output/nlo_ee5j.ref \ ext_tests_nlo/ref-output/nlo_eejj.ref \ ext_tests_nlo/ref-output/nlo_eejjj.ref \ ext_tests_nlo/ref-output/nlo_eett.ref \ ext_tests_nlo/ref-output/nlo_eetth.ref \ ext_tests_nlo/ref-output/nlo_eetthh.ref \ ext_tests_nlo/ref-output/nlo_eetthj.ref \ ext_tests_nlo/ref-output/nlo_eetthz.ref \ ext_tests_nlo/ref-output/nlo_eettwjj.ref \ ext_tests_nlo/ref-output/nlo_eettww.ref \ ext_tests_nlo/ref-output/nlo_eettz.ref \ ext_tests_nlo/ref-output/nlo_eettzj.ref \ ext_tests_nlo/ref-output/nlo_eettzjj.ref \ ext_tests_nlo/ref-output/nlo_eettzz.ref \ ext_tests_nlo/ref-output/nlo_pptttt.ref \ ext_tests_nlo/ref-output/nlo_ppzw.ref \ ext_tests_nlo/ref-output/nlo_ppzz.ref # Reference files that depend on the numerical precision REF_OUTPUT_FILES_DOUBLE = \ functional_tests/ref-output-double/qedtest_3.ref \ functional_tests/ref-output-double/qedtest_4.ref \ functional_tests/ref-output-double/qcdtest_1.ref \ functional_tests/ref-output-double/qcdtest_2.ref \ functional_tests/ref-output-double/qcdtest_3.ref \ functional_tests/ref-output-double/smtest_2.ref \ functional_tests/ref-output-double/smtest_8.ref \ functional_tests/ref-output-double/observables_2.ref \ functional_tests/ref-output-double/colors_2.ref \ functional_tests/ref-output-double/resonances_1.ref \ functional_tests/ref-output-double/resonances_2.ref \ functional_tests/ref-output-double/resonances_3.ref \ functional_tests/ref-output-double/resonances_4.ref \ functional_tests/ref-output-double/resonances_10.ref \ functional_tests/ref-output-double/resonances_11.ref \ functional_tests/ref-output-double/beam_setup_5.ref \ functional_tests/ref-output-double/nlo_3.ref \ functional_tests/ref-output-double/nlo_4.ref \ functional_tests/ref-output-double/nlo_5.ref \ functional_tests/ref-output-double/fks_res_1.ref \ functional_tests/ref-output-double/fks_res_3.ref \ functional_tests/ref-output-double/openloops_3.ref \ functional_tests/ref-output-double/powheg_1.ref \ functional_tests/ref-output-double/defaultcuts.ref \ functional_tests/ref-output-double/parton_shower_2.ref \ functional_tests/ref-output-double/helicity.ref \ functional_tests/ref-output-double/lhef_7.ref \ functional_tests/ref-output-double/hepmc_8.ref \ functional_tests/ref-output-double/lcio_2.ref \ functional_tests/ref-output-double/lcio_7.ref \ functional_tests/ref-output-double/multi_comp_1.ref \ functional_tests/ref-output-double/multi_comp_2.ref \ functional_tests/ref-output-double/multi_comp_3.ref \ functional_tests/ref-output-double/pdf_builtin.ref \ functional_tests/ref-output-double/lhapdf5.ref \ functional_tests/ref-output-double/lhapdf6.ref \ functional_tests/ref-output-double/ep_1.ref \ functional_tests/ref-output-double/ep_2.ref \ functional_tests/ref-output-double/circe1_4.ref \ functional_tests/ref-output-double/circe1_5.ref \ functional_tests/ref-output-double/circe1_7.ref \ functional_tests/ref-output-double/circe1_8.ref \ functional_tests/ref-output-double/circe1_9.ref \ functional_tests/ref-output-double/circe1_photons_1.ref \ functional_tests/ref-output-double/circe1_photons_2.ref \ functional_tests/ref-output-double/circe1_photons_3.ref \ functional_tests/ref-output-double/circe1_photons_4.ref \ functional_tests/ref-output-double/circe1_photons_5.ref \ functional_tests/ref-output-double/isr_2.ref \ functional_tests/ref-output-double/isr_3.ref \ functional_tests/ref-output-double/isr_4.ref \ functional_tests/ref-output-double/isr_5.ref \ functional_tests/ref-output-double/pythia6_3.ref \ functional_tests/ref-output-double/pythia6_4.ref \ functional_tests/ref-output-double/tauola_1.ref \ functional_tests/ref-output-double/tauola_2.ref \ functional_tests/ref-output-double/mlm_matching_isr.ref \ functional_tests/ref-output-double/ewa_1.ref \ functional_tests/ref-output-double/ewa_2.ref \ functional_tests/ref-output-double/ewa_3.ref \ functional_tests/ref-output-double/ilc.ref \ functional_tests/ref-output-double/beam_events_2.ref \ functional_tests/ref-output-double/beam_events_3.ref REF_OUTPUT_FILES_PREC = \ functional_tests/ref-output-prec/qedtest_3.ref \ functional_tests/ref-output-prec/qedtest_4.ref \ functional_tests/ref-output-prec/qcdtest_1.ref \ functional_tests/ref-output-prec/qcdtest_2.ref \ functional_tests/ref-output-prec/qcdtest_3.ref \ functional_tests/ref-output-prec/smtest_2.ref \ functional_tests/ref-output-prec/smtest_8.ref \ functional_tests/ref-output-prec/colors_2.ref \ functional_tests/ref-output-prec/beam_setup_5.ref \ functional_tests/ref-output-prec/nlo_3.ref \ functional_tests/ref-output-prec/nlo_4.ref \ functional_tests/ref-output-prec/fks_res_1.ref \ functional_tests/ref-output-prec/fks_res_3.ref \ functional_tests/ref-output-prec/openloops_3.ref \ functional_tests/ref-output-prec/defaultcuts.ref \ functional_tests/ref-output-prec/parton_shower_2.ref \ functional_tests/ref-output-prec/helicity.ref \ functional_tests/ref-output-prec/lhef_7.ref \ functional_tests/ref-output-prec/multi_comp_1.ref \ functional_tests/ref-output-prec/multi_comp_2.ref \ functional_tests/ref-output-prec/multi_comp_3.ref \ functional_tests/ref-output-prec/pdf_builtin.ref \ functional_tests/ref-output-prec/lhapdf5.ref \ functional_tests/ref-output-prec/lhapdf6.ref \ functional_tests/ref-output-prec/ep_1.ref \ functional_tests/ref-output-prec/ep_2.ref \ functional_tests/ref-output-prec/ilc.ref \ functional_tests/ref-output-prec/circe1_9.ref \ functional_tests/ref-output-prec/circe1_photons_1.ref \ functional_tests/ref-output-prec/circe1_photons_2.ref \ functional_tests/ref-output-prec/circe1_photons_3.ref \ functional_tests/ref-output-prec/circe1_photons_4.ref \ functional_tests/ref-output-prec/circe1_photons_5.ref \ functional_tests/ref-output-prec/ewa_1.ref REF_OUTPUT_FILES_EXT = \ functional_tests/ref-output-ext/observables_2.ref \ functional_tests/ref-output-ext/resonances_1.ref \ functional_tests/ref-output-ext/resonances_2.ref \ functional_tests/ref-output-ext/resonances_3.ref \ functional_tests/ref-output-ext/resonances_4.ref \ functional_tests/ref-output-ext/resonances_10.ref \ functional_tests/ref-output-ext/resonances_11.ref \ functional_tests/ref-output-ext/circe1_4.ref \ functional_tests/ref-output-ext/circe1_5.ref \ functional_tests/ref-output-ext/circe1_7.ref \ functional_tests/ref-output-ext/circe1_8.ref \ functional_tests/ref-output-ext/isr_2.ref \ functional_tests/ref-output-ext/isr_3.ref \ functional_tests/ref-output-ext/isr_4.ref \ functional_tests/ref-output-ext/isr_5.ref \ functional_tests/ref-output-ext/nlo_5.ref \ functional_tests/ref-output-ext/powheg_1.ref \ functional_tests/ref-output-ext/pythia6_3.ref \ functional_tests/ref-output-ext/pythia6_4.ref \ functional_tests/ref-output-ext/tauola_1.ref \ functional_tests/ref-output-ext/tauola_2.ref \ functional_tests/ref-output-ext/ewa_2.ref \ functional_tests/ref-output-ext/ewa_3.ref \ functional_tests/ref-output-ext/beam_events_2.ref \ functional_tests/ref-output-ext/beam_events_3.ref \ functional_tests/ref-output-ext/mlm_matching_isr.ref \ functional_tests/ref-output-ext/hepmc_8.ref \ functional_tests/ref-output-ext/lcio_2.ref \ functional_tests/ref-output-ext/lcio_7.ref REF_OUTPUT_FILES_QUAD = \ functional_tests/ref-output-quad/observables_2.ref \ functional_tests/ref-output-quad/resonances_1.ref \ functional_tests/ref-output-quad/resonances_2.ref \ functional_tests/ref-output-quad/resonances_3.ref \ functional_tests/ref-output-quad/resonances_4.ref \ functional_tests/ref-output-quad/resonances_10.ref \ functional_tests/ref-output-quad/resonances_11.ref \ functional_tests/ref-output-quad/circe1_4.ref \ functional_tests/ref-output-quad/circe1_5.ref \ functional_tests/ref-output-quad/circe1_7.ref \ functional_tests/ref-output-quad/circe1_8.ref \ functional_tests/ref-output-quad/isr_2.ref \ functional_tests/ref-output-quad/isr_3.ref \ functional_tests/ref-output-quad/isr_4.ref \ functional_tests/ref-output-quad/isr_5.ref \ functional_tests/ref-output-quad/nlo_5.ref \ functional_tests/ref-output-quad/powheg_1.ref \ functional_tests/ref-output-quad/pythia6_3.ref \ functional_tests/ref-output-quad/pythia6_4.ref \ functional_tests/ref-output-quad/tauola_1.ref \ functional_tests/ref-output-quad/tauola_2.ref \ functional_tests/ref-output-quad/ewa_2.ref \ functional_tests/ref-output-quad/ewa_3.ref \ functional_tests/ref-output-quad/beam_events_2.ref \ functional_tests/ref-output-quad/beam_events_3.ref \ functional_tests/ref-output-quad/mlm_matching_isr.ref \ functional_tests/ref-output-quad/hepmc_8.ref \ functional_tests/ref-output-quad/lcio_2.ref \ functional_tests/ref-output-quad/lcio_7.ref TESTSUITES_M4 = \ $(MISC_TESTS_M4) \ $(EXT_MSSM_M4) \ $(EXT_NMSSM_M4) TESTSUITES_SIN = \ $(MISC_TESTS_SIN) \ $(EXT_ILC_SIN) \ $(EXT_MSSM_SIN) \ $(EXT_NMSSM_SIN) \ $(EXT_SHOWER_SIN) \ $(EXT_NLO_SIN) \ $(EXT_NLO_ADD_SIN) MISC_TESTS_M4 = MISC_TESTS_SIN = \ functional_tests/empty.sin \ functional_tests/fatal.sin \ functional_tests/pack_1.sin \ functional_tests/defaultcuts.sin \ functional_tests/cuts.sin \ functional_tests/model_change_1.sin \ functional_tests/model_change_2.sin \ functional_tests/model_change_3.sin \ functional_tests/model_scheme_1.sin \ functional_tests/model_test.sin \ functional_tests/structure_1.sin \ functional_tests/structure_2.sin \ functional_tests/structure_3.sin \ functional_tests/structure_4.sin \ functional_tests/structure_5.sin \ functional_tests/structure_6.sin \ functional_tests/structure_7.sin \ functional_tests/structure_8.sin \ functional_tests/vars.sin \ functional_tests/extpar.sin \ functional_tests/testproc_1.sin \ functional_tests/testproc_2.sin \ functional_tests/testproc_3.sin \ functional_tests/testproc_4.sin \ functional_tests/testproc_5.sin \ functional_tests/testproc_6.sin \ functional_tests/testproc_7.sin \ functional_tests/testproc_8.sin \ functional_tests/testproc_9.sin \ functional_tests/testproc_10.sin \ functional_tests/testproc_11.sin \ functional_tests/testproc_12.sin \ functional_tests/template_me_1.sin \ functional_tests/template_me_2.sin \ functional_tests/libraries_1.sin \ functional_tests/libraries_2.sin \ functional_tests/libraries_3.sin \ functional_tests/libraries_4.sin \ functional_tests/job_id_1.sin \ functional_tests/job_id_2.sin \ functional_tests/job_id_3.sin \ functional_tests/job_id_4.sin \ functional_tests/rebuild_1.sin \ functional_tests/rebuild_2.sin \ functional_tests/rebuild_3.sin \ functional_tests/rebuild_4.sin \ functional_tests/rebuild_5.sin \ functional_tests/qedtest_1.sin \ functional_tests/qedtest_2.sin \ functional_tests/qedtest_3.sin \ functional_tests/qedtest_4.sin \ functional_tests/qedtest_5.sin \ functional_tests/qedtest_6.sin \ functional_tests/qedtest_7.sin \ functional_tests/qedtest_8.sin \ functional_tests/qedtest_9.sin \ functional_tests/qedtest_10.sin \ functional_tests/rambo_vamp_1.sin \ functional_tests/rambo_vamp_2.sin \ functional_tests/beam_setup_1.sin \ functional_tests/beam_setup_2.sin \ functional_tests/beam_setup_3.sin \ functional_tests/beam_setup_4.sin \ functional_tests/beam_setup_5.sin \ functional_tests/qcdtest_1.sin \ functional_tests/qcdtest_2.sin \ functional_tests/qcdtest_3.sin \ functional_tests/qcdtest_4.sin \ functional_tests/qcdtest_5.sin \ functional_tests/qcdtest_6.sin \ functional_tests/observables_1.sin \ functional_tests/observables_2.sin \ functional_tests/event_weights_1.sin \ functional_tests/event_weights_2.sin \ functional_tests/event_eff_1.sin \ functional_tests/event_eff_2.sin \ functional_tests/event_dump_1.sin \ functional_tests/event_dump_2.sin \ functional_tests/reweight_1.sin \ functional_tests/reweight_2.sin \ functional_tests/reweight_3.sin \ functional_tests/reweight_4.sin \ functional_tests/reweight_5.sin \ functional_tests/reweight_6.sin \ functional_tests/reweight_7.sin \ functional_tests/reweight_8.sin \ functional_tests/analyze_1.sin \ functional_tests/analyze_2.sin \ functional_tests/analyze_3.sin \ functional_tests/analyze_4.sin \ functional_tests/analyze_5.sin \ functional_tests/analyze_6.sin \ functional_tests/bjet_cluster.sin \ functional_tests/colors.sin \ functional_tests/colors_2.sin \ functional_tests/colors_hgg.sin \ functional_tests/alphas.sin \ functional_tests/jets_xsec.sin \ functional_tests/lhef_1.sin \ functional_tests/lhef_2.sin \ functional_tests/lhef_3.sin \ functional_tests/lhef_4.sin \ functional_tests/lhef_5.sin \ functional_tests/lhef_6.sin \ functional_tests/lhef_7.sin \ functional_tests/lhef_8.sin \ functional_tests/lhef_9.sin \ functional_tests/lhef_10.sin \ functional_tests/lhef_11.sin \ functional_tests/select_1.sin \ functional_tests/select_2.sin \ functional_tests/shower_err_1.sin \ functional_tests/parton_shower_1.sin \ functional_tests/parton_shower_2.sin \ functional_tests/pythia6_1.sin \ functional_tests/pythia6_2.sin \ functional_tests/pythia6_3.sin \ functional_tests/pythia6_4.sin \ functional_tests/pythia8_1.sin \ functional_tests/pythia8_2.sin \ functional_tests/hadronize_1.sin \ functional_tests/tauola_1.sin \ functional_tests/tauola_2.sin \ functional_tests/mlm_matching_fsr.sin \ functional_tests/mlm_matching_isr.sin \ functional_tests/mlm_pythia6_isr.sin \ functional_tests/hepmc_1.sin \ functional_tests/hepmc_2.sin \ functional_tests/hepmc_3.sin \ functional_tests/hepmc_4.sin \ functional_tests/hepmc_5.sin \ functional_tests/hepmc_6.sin \ functional_tests/hepmc_7.sin \ functional_tests/hepmc_8.sin \ functional_tests/hepmc_9.sin \ functional_tests/hepmc_10.sin \ functional_tests/stdhep_1.sin \ functional_tests/stdhep_2.sin \ functional_tests/stdhep_3.sin \ functional_tests/stdhep_4.sin \ functional_tests/stdhep_5.sin \ functional_tests/stdhep_6.sin \ functional_tests/lcio_1.sin \ functional_tests/lcio_2.sin \ functional_tests/lcio_3.sin \ functional_tests/lcio_4.sin \ functional_tests/lcio_5.sin \ functional_tests/lcio_6.sin \ functional_tests/lcio_7.sin \ functional_tests/lcio_8.sin \ functional_tests/lcio_9.sin \ functional_tests/lcio_10.sin \ functional_tests/fatal_beam_decay.sin \ functional_tests/smtest_1.sin \ functional_tests/smtest_2.sin \ functional_tests/smtest_3.sin \ functional_tests/smtest_4.sin \ functional_tests/smtest_5.sin \ functional_tests/smtest_6.sin \ functional_tests/smtest_7.sin \ functional_tests/smtest_8.sin \ functional_tests/smtest_9.sin \ functional_tests/smtest_10.sin \ functional_tests/smtest_11.sin \ functional_tests/smtest_12.sin \ functional_tests/smtest_13.sin \ functional_tests/smtest_14.sin \ functional_tests/smtest_15.sin \ functional_tests/smtest_16.sin \ functional_tests/photon_isolation_1.sin \ functional_tests/photon_isolation_2.sin \ functional_tests/resonances_1.sin \ functional_tests/resonances_2.sin \ functional_tests/resonances_3.sin \ functional_tests/resonances_4.sin \ functional_tests/resonances_5.sin \ functional_tests/resonances_6.sin \ functional_tests/resonances_7.sin \ functional_tests/resonances_8.sin \ functional_tests/resonances_9.sin \ functional_tests/resonances_10.sin \ functional_tests/resonances_11.sin \ functional_tests/resonances_12.sin \ functional_tests/sm_cms_1.sin \ functional_tests/ufo_1.sin \ functional_tests/ufo_2.sin \ functional_tests/ufo_3.sin \ + functional_tests/ufo_4.sin \ functional_tests/nlo_1.sin \ functional_tests/nlo_2.sin \ functional_tests/nlo_3.sin \ functional_tests/nlo_4.sin \ functional_tests/nlo_5.sin \ functional_tests/nlo_6.sin \ functional_tests/nlo_decay_1.sin \ functional_tests/real_partition_1.sin \ functional_tests/fks_res_1.sin \ functional_tests/fks_res_2.sin \ functional_tests/fks_res_3.sin \ functional_tests/openloops_1.sin \ functional_tests/openloops_2.sin \ functional_tests/openloops_3.sin \ functional_tests/openloops_4.sin \ functional_tests/openloops_5.sin \ functional_tests/openloops_6.sin \ functional_tests/openloops_7.sin \ functional_tests/openloops_8.sin \ functional_tests/openloops_9.sin \ functional_tests/openloops_10.sin \ functional_tests/openloops_11.sin \ functional_tests/openloops_12.sin \ functional_tests/openloops_13.sin \ functional_tests/recola_1.sin \ functional_tests/recola_2.sin \ functional_tests/recola_3.sin \ functional_tests/recola_4.sin \ functional_tests/recola_5.sin \ functional_tests/recola_6.sin \ functional_tests/recola_7.sin \ functional_tests/recola_8.sin \ functional_tests/powheg_1.sin \ functional_tests/mssmtest_1.sin \ functional_tests/mssmtest_2.sin \ functional_tests/mssmtest_3.sin \ functional_tests/spincor_1.sin \ functional_tests/show_1.sin \ functional_tests/show_2.sin \ functional_tests/show_3.sin \ functional_tests/show_4.sin \ functional_tests/show_5.sin \ functional_tests/method_ovm_1.sin \ functional_tests/multi_comp_1.sin \ functional_tests/multi_comp_2.sin \ functional_tests/multi_comp_3.sin \ functional_tests/multi_comp_4.sin \ functional_tests/flvsum_1.sin \ functional_tests/br_redef_1.sin \ functional_tests/decay_err_1.sin \ functional_tests/decay_err_2.sin \ functional_tests/decay_err_3.sin \ functional_tests/polarized_1.sin \ functional_tests/pdf_builtin.sin \ functional_tests/lhapdf5.sin \ functional_tests/lhapdf6.sin \ functional_tests/ep_1.sin \ functional_tests/ep_2.sin \ functional_tests/ep_3.sin \ functional_tests/circe1_1.sin \ functional_tests/circe1_2.sin \ functional_tests/circe1_3.sin \ functional_tests/circe1_4.sin \ functional_tests/circe1_5.sin \ functional_tests/circe1_6.sin \ functional_tests/circe1_7.sin \ functional_tests/circe1_8.sin \ functional_tests/circe1_9.sin \ functional_tests/circe1_10.sin \ functional_tests/circe1_photons_1.sin \ functional_tests/circe1_photons_2.sin \ functional_tests/circe1_photons_3.sin \ functional_tests/circe1_photons_4.sin \ functional_tests/circe1_photons_5.sin \ functional_tests/circe1_errors_1.sin \ functional_tests/circe2_1.sin \ functional_tests/circe2_2.sin \ functional_tests/circe2_3.sin \ functional_tests/isr_1.sin \ functional_tests/isr_2.sin \ functional_tests/isr_3.sin \ functional_tests/isr_4.sin \ functional_tests/isr_5.sin \ functional_tests/epa_1.sin \ functional_tests/epa_2.sin \ functional_tests/isr_epa_1.sin \ functional_tests/ewa_1.sin \ functional_tests/ewa_2.sin \ functional_tests/ewa_3.sin \ functional_tests/ewa_4.sin \ functional_tests/ilc.sin \ functional_tests/gaussian_1.sin \ functional_tests/gaussian_2.sin \ functional_tests/beam_events_1.sin \ functional_tests/beam_events_2.sin \ functional_tests/beam_events_3.sin \ functional_tests/beam_events_4.sin \ functional_tests/energy_scan_1.sin \ functional_tests/susyhit.sin \ functional_tests/restrictions.sin \ functional_tests/helicity.sin \ functional_tests/process_log.sin \ functional_tests/static_1.sin \ functional_tests/static_1.exe.sin \ functional_tests/static_2.sin \ functional_tests/static_2.exe.sin \ functional_tests/user_cuts.sin \ functional_tests/user_prc_threshold_1.sin \ functional_tests/cascades2_phs_1.sin \ functional_tests/user_prc_threshold_2.sin \ functional_tests/vamp2_1.sin \ functional_tests/vamp2_2.sin EXT_MSSM_M4 = \ ext_tests_mssm/mssm_ext-ee.m4 \ ext_tests_mssm/mssm_ext-ee2.m4 \ ext_tests_mssm/mssm_ext-en.m4 \ ext_tests_mssm/mssm_ext-tn.m4 \ ext_tests_mssm/mssm_ext-uu.m4 \ ext_tests_mssm/mssm_ext-uu2.m4 \ ext_tests_mssm/mssm_ext-uuckm.m4 \ ext_tests_mssm/mssm_ext-dd.m4 \ ext_tests_mssm/mssm_ext-dd2.m4 \ ext_tests_mssm/mssm_ext-ddckm.m4 \ ext_tests_mssm/mssm_ext-bb.m4 \ ext_tests_mssm/mssm_ext-bt.m4 \ ext_tests_mssm/mssm_ext-tt.m4 \ ext_tests_mssm/mssm_ext-ug.m4 \ ext_tests_mssm/mssm_ext-dg.m4 \ ext_tests_mssm/mssm_ext-aa.m4 \ ext_tests_mssm/mssm_ext-wa.m4 \ ext_tests_mssm/mssm_ext-za.m4 \ ext_tests_mssm/mssm_ext-ww.m4 \ ext_tests_mssm/mssm_ext-wz.m4 \ ext_tests_mssm/mssm_ext-zz.m4 \ ext_tests_mssm/mssm_ext-gg.m4 \ ext_tests_mssm/mssm_ext-ga.m4 \ ext_tests_mssm/mssm_ext-gw.m4 \ ext_tests_mssm/mssm_ext-gz.m4 EXT_NMSSM_M4 = \ ext_tests_nmssm/nmssm_ext-aa.m4 \ ext_tests_nmssm/nmssm_ext-bb1.m4 \ ext_tests_nmssm/nmssm_ext-bb2.m4 \ ext_tests_nmssm/nmssm_ext-bt.m4 \ ext_tests_nmssm/nmssm_ext-dd1.m4 \ ext_tests_nmssm/nmssm_ext-dd2.m4 \ ext_tests_nmssm/nmssm_ext-ee1.m4 \ ext_tests_nmssm/nmssm_ext-ee2.m4 \ ext_tests_nmssm/nmssm_ext-en.m4 \ ext_tests_nmssm/nmssm_ext-ga.m4 \ ext_tests_nmssm/nmssm_ext-gg.m4 \ ext_tests_nmssm/nmssm_ext-gw.m4 \ ext_tests_nmssm/nmssm_ext-gz.m4 \ ext_tests_nmssm/nmssm_ext-qg.m4 \ ext_tests_nmssm/nmssm_ext-tn.m4 \ ext_tests_nmssm/nmssm_ext-tt1.m4 \ ext_tests_nmssm/nmssm_ext-tt2.m4 \ ext_tests_nmssm/nmssm_ext-uu1.m4 \ ext_tests_nmssm/nmssm_ext-uu2.m4 \ ext_tests_nmssm/nmssm_ext-wa.m4 \ ext_tests_nmssm/nmssm_ext-ww1.m4 \ ext_tests_nmssm/nmssm_ext-ww2.m4 \ ext_tests_nmssm/nmssm_ext-wz.m4 \ ext_tests_nmssm/nmssm_ext-za.m4 \ ext_tests_nmssm/nmssm_ext-zz1.m4 \ ext_tests_nmssm/nmssm_ext-zz2.m4 EXT_MSSM_SIN = $(EXT_MSSM_M4:.m4=.sin) EXT_NMSSM_SIN = $(EXT_NMSSM_M4:.m4=.sin) EXT_ILC_SIN = \ ext_tests_ilc/ilc_ext.sin EXT_SHOWER_SIN = \ ext_tests_shower/shower_1_norad.sin \ ext_tests_shower/shower_2_aall.sin \ ext_tests_shower/shower_3_bb.sin \ ext_tests_shower/shower_3_jj.sin \ ext_tests_shower/shower_3_qqqq.sin \ ext_tests_shower/shower_3_tt.sin \ ext_tests_shower/shower_3_z_nu.sin \ ext_tests_shower/shower_3_z_tau.sin \ ext_tests_shower/shower_4_ee.sin \ ext_tests_shower/shower_5.sin \ ext_tests_shower/shower_6.sin EXT_NLO_SIN = \ ext_tests_nlo/nlo_settings.sin \ ext_tests_nlo/nlo_eejj.sin \ ext_tests_nlo/nlo_eejjj.sin \ ext_tests_nlo/nlo_ee4j.sin \ ext_tests_nlo/nlo_ee5j.sin \ ext_tests_nlo/nlo_eebb.sin \ ext_tests_nlo/nlo_eebbj.sin \ ext_tests_nlo/nlo_eebbjj.sin \ ext_tests_nlo/nlo_ee4b.sin \ ext_tests_nlo/nlo_eett.sin \ ext_tests_nlo/nlo_eettj.sin \ ext_tests_nlo/nlo_eettjj.sin \ ext_tests_nlo/nlo_eettjjj.sin \ ext_tests_nlo/nlo_eettbb.sin \ ext_tests_nlo/nlo_eetta.sin \ ext_tests_nlo/nlo_eettaa.sin \ ext_tests_nlo/nlo_eettaj.sin \ ext_tests_nlo/nlo_eettajj.sin \ ext_tests_nlo/nlo_eettaz.sin \ ext_tests_nlo/nlo_eettah.sin \ ext_tests_nlo/nlo_eettz.sin \ ext_tests_nlo/nlo_eettzj.sin \ ext_tests_nlo/nlo_eettzjj.sin \ ext_tests_nlo/nlo_eettzz.sin \ ext_tests_nlo/nlo_eettwjj.sin \ ext_tests_nlo/nlo_eettww.sin \ ext_tests_nlo/nlo_eetth.sin \ ext_tests_nlo/nlo_eetthj.sin \ ext_tests_nlo/nlo_eetthjj.sin \ ext_tests_nlo/nlo_eetthh.sin \ ext_tests_nlo/nlo_eetthz.sin \ ext_tests_nlo/nlo_ee4t.sin \ ext_tests_nlo/nlo_ee4tj.sin \ ext_tests_nlo/nlo_ppzz.sin \ ext_tests_nlo/nlo_ppzw.sin \ ext_tests_nlo/nlo_pptttt.sin EXT_NLO_ADD_SIN = \ ext_tests_nlo_add/nlo_decay_tbw.sin \ ext_tests_nlo_add/nlo_tt.sin \ ext_tests_nlo_add/nlo_tt_powheg.sin \ ext_tests_nlo_add/nlo_tt_powheg_sudakov.sin \ ext_tests_nlo_add/nlo_uu.sin \ ext_tests_nlo_add/nlo_uu_powheg.sin \ ext_tests_nlo_add/nlo_qq_powheg.sin \ ext_tests_nlo_add/nlo_threshold.sin \ ext_tests_nlo_add/nlo_threshold_factorized.sin \ ext_tests_nlo_add/nlo_methods_gosam.sin \ ext_tests_nlo_add/nlo_jets.sin \ ext_tests_nlo_add/nlo_fks_delta_o_eejj.sin \ ext_tests_nlo_add/nlo_fks_delta_i_ppee.sin all-local: $(TESTSUITES_SIN) if M4_AVAILABLE SUFFIXES = .m4 .sin .m4.sin: case "$@" in \ */*) \ mkdir -p `sed 's,/.[^/]*$$,,g' <<< "$@"` ;; \ esac $(M4) $(srcdir)/$(TESTSUITE_MACROS) $< > $@ endif M4_AVAILABLE Index: trunk/share/tests/functional_tests/ref-output/ufo_4.ref =================================================================== --- trunk/share/tests/functional_tests/ref-output/ufo_4.ref (revision 0) +++ trunk/share/tests/functional_tests/ref-output/ufo_4.ref (revision 8346) @@ -0,0 +1,336 @@ +?openmp_logging = false +?vis_history = false +?integration_timer = false +| Switching to model 'ufo_4_SM' (generated from UFO source) +seed = 0 +?resonance_history = true +resonance_on_shell_limit = 4.000000000000E+00 +phs_off_shell = 1 +phs_t_channel = 2 +ufo_4_SM.MH => 1.250000000000E+02 +$restrictions = "3+4~H && 5+6~Z" +| Process library 'ufo_4_lib': recorded process 'ufo_4_zh' +| Restoring model 'ufo_4_SM' +sqrts = 5.000000000000E+02 +openmp_num_threads = 1 +| Integrate: current process library needs compilation +| Process library 'ufo_4_lib': compiling ... +| Process library 'ufo_4_lib': writing makefile +| Process library 'ufo_4_lib': removing old files +| Process library 'ufo_4_lib': writing driver +| Process library 'ufo_4_lib': creating source code +| Process library 'ufo_4_lib': compiling sources +| Process library 'ufo_4_lib': linking +| Process library 'ufo_4_lib': loading +| Process library 'ufo_4_lib': ... success. +| Integrate: compilation done +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 0 +| Initializing integration for process ufo_4_zh: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| Phase space: generating configuration ... +| Phase space: ... success. +| Phase space: writing configuration file 'ufo_4_zh.i1.phs' +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh' +| Library name = 'ufo_4_lib' +| Process index = 1 +| Process components: +| 1: 'ufo_4_zh_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: 60 channels, 8 dimensions +| Phase space: found 60 channels, collected in 16 groves. +| Phase space: Using 104 equivalences between channels. +| Phase space: wood +Warning: No cuts have been defined. +| Starting integration for process 'ufo_4_zh' +| Integrate: iterations = 1:1000 +| Integrator: 16 chains, 60 channels, 8 dimensions +| Integrator: Using VAMP channel equivalences +| Integrator: 1000 initial calls, 20 bins, stratified = T +| Integrator: VAMP +|=============================================================================| +| It Calls Integral[fb] Error[fb] Err[%] Acc Eff[%] Chi2 N[It] | +|=============================================================================| + 1 960 2.9296043E+00 1.95E-01 6.64 2.06* 39.35 +|-----------------------------------------------------------------------------| + 1 960 2.9296043E+00 1.95E-01 6.64 2.06 39.35 +|=============================================================================| +| Restoring model 'ufo_4_SM' +n_events = 10 +| Starting simulation for process 'ufo_4_zh' +| Simulate: using integration grids from file 'ufo_4_zh.m1.vg' +| Creating library for resonant subprocesses 'ufo_4_zh_R' +| Process library 'ufo_4_zh_R': initialized +| Resonant subprocess #1: 3+4~H && 5+6~H +| Process library 'ufo_4_zh_R': recorded process 'ufo_4_zh_R1' +| Resonant subprocess #2: 3+4~Z && 5+6~H +| Process library 'ufo_4_zh_R': recorded process 'ufo_4_zh_R2' +| Resonant subprocess #3: 3+4~H && 5+6~Z +| Process library 'ufo_4_zh_R': recorded process 'ufo_4_zh_R3' +| Resonant subprocess #4: 3+4~Z && 5+6~Z +| Process library 'ufo_4_zh_R': recorded process 'ufo_4_zh_R4' +| Resonant subprocess #5: 3+4~Z && 3+4+5+6~H +| Process library 'ufo_4_zh_R': recorded process 'ufo_4_zh_R5' +| Resonant subprocess #6: 5+6~Z && 3+4+5+6~H +| Process library 'ufo_4_zh_R': recorded process 'ufo_4_zh_R6' +| Resonant subprocess #7: 3+4+5+6~H +| Process library 'ufo_4_zh_R': recorded process 'ufo_4_zh_R7' +| Resonant subprocess #8: 3+4+5+6~Z +| Process library 'ufo_4_zh_R': recorded process 'ufo_4_zh_R8' +| Resonant subprocess #9: 3+4~H +| Process library 'ufo_4_zh_R': recorded process 'ufo_4_zh_R9' +| Resonant subprocess #10: 5+6~H +| Process library 'ufo_4_zh_R': recorded process 'ufo_4_zh_R10' +| Resonant subprocess #11: 3+4~Z +| Process library 'ufo_4_zh_R': recorded process 'ufo_4_zh_R11' +| Resonant subprocess #12: 5+6~Z +| Process library 'ufo_4_zh_R': recorded process 'ufo_4_zh_R12' +| Process library 'ufo_4_zh_R': compiling ... +| Process library 'ufo_4_zh_R': writing makefile +| Process library 'ufo_4_zh_R': removing old files +| Process library 'ufo_4_zh_R': writing driver +| Process library 'ufo_4_zh_R': creating source code +| Process library 'ufo_4_zh_R': compiling sources +| Process library 'ufo_4_zh_R': linking +| Process library 'ufo_4_zh_R': loading +| Process library 'ufo_4_zh_R': ... success. +| Simulate: initializing resonant subprocess 'ufo_4_zh_R1' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 1 +| Initializing integration for process ufo_4_zh_R1: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh_R1' +| Library name = 'ufo_4_zh_R' +| Process index = 1 +| Process components: +| 1: 'ufo_4_zh_R1_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: none +Warning: No cuts have been defined. +| Simulate: initializing resonant subprocess 'ufo_4_zh_R2' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 2 +| Initializing integration for process ufo_4_zh_R2: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh_R2' +| Library name = 'ufo_4_zh_R' +| Process index = 2 +| Process components: +| 1: 'ufo_4_zh_R2_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: none +Warning: No cuts have been defined. +| Simulate: initializing resonant subprocess 'ufo_4_zh_R3' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 3 +| Initializing integration for process ufo_4_zh_R3: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh_R3' +| Library name = 'ufo_4_zh_R' +| Process index = 3 +| Process components: +| 1: 'ufo_4_zh_R3_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: none +Warning: No cuts have been defined. +| Simulate: initializing resonant subprocess 'ufo_4_zh_R4' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 4 +| Initializing integration for process ufo_4_zh_R4: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh_R4' +| Library name = 'ufo_4_zh_R' +| Process index = 4 +| Process components: +| 1: 'ufo_4_zh_R4_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: none +Warning: No cuts have been defined. +| Simulate: initializing resonant subprocess 'ufo_4_zh_R5' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 5 +| Initializing integration for process ufo_4_zh_R5: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh_R5' +| Library name = 'ufo_4_zh_R' +| Process index = 5 +| Process components: +| 1: 'ufo_4_zh_R5_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: none +Warning: No cuts have been defined. +| Simulate: initializing resonant subprocess 'ufo_4_zh_R6' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 6 +| Initializing integration for process ufo_4_zh_R6: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh_R6' +| Library name = 'ufo_4_zh_R' +| Process index = 6 +| Process components: +| 1: 'ufo_4_zh_R6_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: none +Warning: No cuts have been defined. +| Simulate: initializing resonant subprocess 'ufo_4_zh_R7' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 7 +| Initializing integration for process ufo_4_zh_R7: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh_R7' +| Library name = 'ufo_4_zh_R' +| Process index = 7 +| Process components: +| 1: 'ufo_4_zh_R7_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: none +Warning: No cuts have been defined. +| Simulate: initializing resonant subprocess 'ufo_4_zh_R8' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 8 +| Initializing integration for process ufo_4_zh_R8: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh_R8' +| Library name = 'ufo_4_zh_R' +| Process index = 8 +| Process components: +| 1: 'ufo_4_zh_R8_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: none +Warning: No cuts have been defined. +| Simulate: initializing resonant subprocess 'ufo_4_zh_R9' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 9 +| Initializing integration for process ufo_4_zh_R9: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh_R9' +| Library name = 'ufo_4_zh_R' +| Process index = 9 +| Process components: +| 1: 'ufo_4_zh_R9_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: none +Warning: No cuts have been defined. +| Simulate: initializing resonant subprocess 'ufo_4_zh_R10' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 10 +| Initializing integration for process ufo_4_zh_R10: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh_R10' +| Library name = 'ufo_4_zh_R' +| Process index = 10 +| Process components: +| 1: 'ufo_4_zh_R10_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: none +Warning: No cuts have been defined. +| Simulate: initializing resonant subprocess 'ufo_4_zh_R11' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 11 +| Initializing integration for process ufo_4_zh_R11: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh_R11' +| Library name = 'ufo_4_zh_R' +| Process index = 11 +| Process components: +| 1: 'ufo_4_zh_R11_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: none +Warning: No cuts have been defined. +| Simulate: initializing resonant subprocess 'ufo_4_zh_R12' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 12 +| Initializing integration for process ufo_4_zh_R12: +| Beam structure: [any particles] +| Beam data (collision): +| e- (mass = 5.1100000E-04 GeV) +| e+ (mass = 5.1100000E-04 GeV) +| sqrts = 5.000000000000E+02 GeV +| ------------------------------------------------------------------------ +| Process [scattering]: 'ufo_4_zh_R12' +| Library name = 'ufo_4_zh_R' +| Process index = 12 +| Process components: +| 1: 'ufo_4_zh_R12_i1': e-, e+ => b, b~, mu-, mu+ [omega] +| ------------------------------------------------------------------------ +| Phase space: none +Warning: No cuts have been defined. +| Simulate: activating resonance insertion +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 13 +| Simulation: requested number of events = 10 +| corr. to luminosity [fb-1] = 3.4134E+00 +| Events: writing to LHEF file 'ufo_4_zh.lhe' +| Events: writing to raw file 'ufo_4_zh.evx' +| Events: generating 10 unweighted, unpolarized events ... +| Events: event normalization mode '1' +| ... event sample complete. +| Events: actual unweighting efficiency = 29.41 % +Warning: Encountered events with excess weight: 3 events ( 30.000 %) +| Maximum excess weight = 2.181E-01 +| Average excess weight = 5.113E-02 +| Events: closing LHEF file 'ufo_4_zh.lhe' +| Events: closing raw file 'ufo_4_zh.evx' +| There were no errors and 14 warning(s). +| WHIZARD run finished. +|=============================================================================| Index: trunk/share/tests/functional_tests/ufo_4.sin =================================================================== --- trunk/share/tests/functional_tests/ufo_4.sin (revision 0) +++ trunk/share/tests/functional_tests/ufo_4.sin (revision 8346) @@ -0,0 +1,32 @@ +# SINDARIN input for WHIZARD self-test +# Test UFO models with resonance histories + +?logging = true +?openmp_logging = false +?vis_history = false +?integration_timer = false + +model = ufo_4_SM (ufo ("./ufo_4_models")) + +seed = 0 + +?resonance_history = true +resonance_on_shell_limit = 4 + +phs_off_shell = 1 +phs_t_channel = 2 + +MH = 125 GeV + +process ufo_4_zh = "e-", "e+" => "b", "b~", "mu-", "mu+" + { $restrictions = "3+4~H && 5+6~Z" } + +sqrts = 500 GeV +!!! Tests should be run single-threaded +openmp_num_threads = 1 + +integrate (ufo_4_zh) { iterations = 1:1000 } + +n_events = 10 +sample_format = lhef +simulate (ufo_4_zh) \ No newline at end of file