Index: trunk/ChangeLog =================================================================== --- trunk/ChangeLog (revision 8477) +++ trunk/ChangeLog (revision 8478) @@ -1,2166 +1,2169 @@ ChangeLog -- Summary of changes to the WHIZARD package Use svn log to see detailed changes. Version 3.0.0_beta+ +2020-12-08 + Bug fix in expanded p-wave form factor for top threshold + 2020-12-06 Patch for macOS Big Sur shared library handling due to libtool; the patch also demands gcc/gfortran 11.0/10.3/9.4/8.5 2020-12-04 O'Mega only inserts non-vanishing couplings from UFO models 2020-11-21 Bug fix for fractional hypercharges in UFO models 2020-11-11 Enable PYTHIA6 settings for eh collisions (enable-pythia6_eh) 2020-11-09 Correct flavor assignment for NLO fixed-order events 2020-11-05 Bug fix for ISR handler not working with unstable particles 2020-10-08 Bug fix in LHAPDF interface for photon PDFs 2020-10-07 Bug fix for structure function setup with asymmetric beams 2020-10-02 Python/Cython layer for WHIZARD API 2020-09-30 Allow mismatches of Python and name attributes in UFO models 2020-09-26 Support for negative PDG particles from certain UFO models 2020-09-24 Allow for QNUMBERS blocks in BSM SLHA files 2020-09-22 Full support for compilation with clang(++) on Darwin/macOS More documentation in the manual Minor clean-ups 2020-09-16 Bug fix enables reading LCIO events with LCIO v2.15+ ################################################################## 2020-09-16 RELEASE: version 2.8.5 2020-09-11 Bug fix for H->tau tau transverse polarization with PYTHIA6 (thanks to Junping Tian / Akiya Miyamoto) 2020-09-09 Fix a long standing bug (since 2.0) in the calculation of color factors when particles of different color were combined in a particle class. NB: O'Mega never produced a wrong number, it only declared all processes as invalid. 2020-09-08 Enable Openloops matrix element equivalences for optimization 2020-09-02 Compatibility fix for PYTHIA v8.301+ interface 2020-09-01 Support exclusive jet clustering in ee for Fastjet interface ################################################################## 2020-08-30 RELEASE: version 3.0.0_beta 2020-08-27 Major revision of NLO distributions and events for processes with structure functions: - Use parton momenta/flavors (instead of beams) for events - Bug fix for Lorentz boosts and Lorentz frames of momenta - Bug fix: apply cuts to virtual NLO component in correct frame - Correctly assign ISR radiation momenta in data structures - Refactoring on quantum numbers for NLO event data structures - Functional tests for hadron collider NLO distributions - many minor bug fixes regarding NLO hadron collider physics 2020-08-11 Bug fix for linking problem with OpenMPI 2020-08-07 New WHIZARD API: WHIZARD can be externally linked as a library, added examples for Fortran, C, C++ programs ################################################################## 2020-07-08 RELEASE: version 2.8.4 2020-07-07 Bug fix: steering of UFO Majorana models from WHIZARD ################################################################## 2020-07-06 Combined integration also for hadron collider processes at NLO 2020-07-05 Bug fix: correctly steer e+e- FastJet clustering algorithms Major revision of NLO differential distributions and events: - Correctly assign quantum numbers to NLO fixed-order events - Correctly assign weights to NLO fixed-order events for combined simulation - Cut all NLO fixed-order subevents in event groups individually - Only allow "sigma" normalization for NLO fixed-order events - Use correct PDF setup for NLO counter events - Several technical fixes and updates of the NLO testsuite ################################################################## 2020-07-03 RELEASE: version 2.8.3 2020-07-02 Feature-complete UFO implementation for Majorana fermions 2020-06-22 Running width scheme supported for O'Mega matrix elements 2020-06-20 Adding H-s-s coupling to SM_Higgs(_CKM) models 2020-06-17 Completion of ILC 2->6 fermion extended test suite 2020-06-15 Bug fix: PYTHIA6/Tauola, correctly assign tau spins for stau decays 2020-06-09 Bug fix: correctly update calls for additional VAMP/2 iterations Bug fix: correct assignment for tau spins from PYTHIA6 interface 2020-06-04 Bug fix: cascades2 tree merge with empty subtree(s) 2020-05-31 Switch $epa_mode for different EPA implementations 2020-05-26 Bug fix: spin information transferred for resonance histories 2020-04-13 HepMC: correct weighted events for non-xsec event normalizations 2020-04-04 Improved HepMC3 interface: HepMC3 Root/RootTree interface 2020-03-24 ISR: Fix on-shell kinematics for events with ?isr_handler=true (set ?isr_handler_keep_mass=false for old behavior) 2020-03-11 Beam masses are correctly passed to hard matrix element for CIRCE2 EPA with polarized beams: double-counting corrected ################################################################## 2020-03-03 RELEASE: version 3.0.0_alpha 2020-02-25 Bug fix: Scale and alphas can be retrieved from internal event format to external formats 2020-02-17 Bug fix: ?keep_failed_events now forces output of actual event data Bug fix: particle-set reconstruction (rescanning events w/o radiation) 2020-01-28 Bug fix for left-over EPA parameter epa_e_max (replaced by epa_q_max) 2020-01-23 Bug fix for real components of NLO QCD 2->1 processes 2020-01-22 Bug fix: correct random number sequencing during parallel MPI event generation with rng_stream 2020-01-21 Consistent distribution of events during parallel MPI event generation 2020-01-20 Bug fix for configure setup for automake v1.16+ 2020-01-18 General SLHA parameter files for UFO models supported 2020-01-08 Bug fix: correctly register RECOLA processes with flavor sums 2019-12-19 Support for UFO customized propagators O'Mega unit tests for fermion-number violating interactions 2019-12-10 For distribution building: check for graphviz/dot version 2.40 or newer 2019-11-21 Bug fix: alternate setups now work correctly Infrastructure for accessing alpha_QED event-by-event Guard against tiny numbers that break ASCII event output Enable inverse hyperbolic functions as SINDARIN observables Remove old compiler bug workarounds 2019-11-20 Allow quoted -e argument, implemented -f option 2019-11-19 Bug fix: resonance histories now work also with UFO models Fix in numerical precision of ASCII VAMP2 grids 2019-11-06 Add squared matrix elements to the LCIO event header 2019-11-05 Do not include RNG state in MD5 sum for CIRCE1/2 2019-11-04 Full CIRCE2 ILC 250 and 500 GeV beam spectra added Minor update on LCIO event header information 2019-10-30 NLO QCD for final states completed When using Openloops, v2.1.1+ mandatory 2019-10-25 Binary grid files for VAMP2 integrator ################################################################## 2019-10-24 RELEASE: version 2.8.2 2019-10-20 Bug fix for HepMC linker flags 2019-10-19 Support for spin-2 particles from UFO files 2019-09-27 LCIO event format allows rescan and alternate weights 2019-09-24 Compatibility fix for OCaml v4.08.0+ ################################################################## 2019-09-21 RELEASE: version 2.8.1 2019-09-19 Carriage return characters in UFO models can be parsed Mathematica symbols in UFO models possible Unused/undefined parameters in UFO models handled 2019-09-13 New extended NLO test suite for ee and pp processes 2019-09-09 Photon isolation (separation of perturbative and fragmentation part a la Frixione) 2019-09-05 Major progress on NLO QCD for hadron collisions: - correctly assign flavor structures for alpha regions - fix crossing of particles for initial state splittings - correct assignment for PDF factors for real subtractions - fix kinematics for collinear splittings - bug fix for integrated virtual subtraction terms 2019-09-03 b and c jet selection in cuts and analysis 2019-08-27 Support for Intel MPI 2019-08-20 Complete (preliminary) HepMC3 support (incl. backwards HepMC2 write/read mode) 2019-08-08 Bug fix: handle carriage returns in UFO files (non-Unix OS) ################################################################## 2019-08-07 RELEASE: version 2.8.0 2019-07-31 Complete WHIZARD UFO interface: - general Lorentz structures - matrix element support for general color factors - missing features: Majorana fermions and SLHA 2019-07-20 Make WHIZARD compatible with OCaml 4.08.0+ 2019-07-19 Fix version testing for LHAPDF 6.2.3 and newer Minimal required OCaml version is now 4.02.3. 2019-04-18 Correctly generate ordered FKS tuples for alpha regions from all possible underlying Born processes 2019-04-08 Extended O'Mega/Recola matrix element test suite 2019-03-29 Correct identical particle symmetry factors for FKS subtraction 2019-03-28 Correct assertion of spin-correlated matrix elements for hadron collisions 2019-03-27 Bug fix for cut-off parameter delta_i for collinear plus/minus regions ################################################################## 2019-03-27 RELEASE: version 2.7.1 2019-02-19 Further infrastructure for HepMC3 interface (v3.01.00) 2019-02-07 Explicit configure option for using debugging options Bug fix for performance by removing unnecessary debug operations 2019-01-29 Bug fix for DGLAP remnants with cut-off parameter delta_i 2019-01-24 Radiative decay neu2 -> neu1 A added to MSSM_Hgg model ################################################################## 2019-01-21 RELEASE: version 2.7.0 2018-12-18 Support RECOLA for integrated und unintegrated subtractions 2018-12-11 FCNC top-up sector in model SM_top_anom 2018-12-05 Use libtirpc instead of SunRPC on Arch Linux etc. 2018-11-30 Display rescaling factor for weighted event samples with cuts 2018-11-29 Reintroduce check against different masses in flavor sums Bug fix for wrong couplings in the Littlest Higgs model(s) 2018-11-22 Bug fix for rescanning events with beam structure 2018-11-09 Major refactoring of internal process data 2018-11-02 PYTHIA8 interface 2018-10-29 Flat phase space parametrization with RAMBO (on diet) implemented 2018-10-17 Revise extended test suite 2018-09-27 Process container for RECOLA processes 2018-09-15 Fixes by M. Berggren for PYTHIA6 interface 2018-09-14 First fixes after HepForge modernization ################################################################## 2018-08-23 RELEASE: version 2.6.4 2018-08-09 Infrastructure to check colored subevents 2018-07-10 Infrastructure for running WHIZARD in batch mode 2018-07-04 MPI available from distribution tarball 2018-06-03 Support Intel Fortran Compiler under MAC OS X 2018-05-07 FKS slicing parameter delta_i (initial state) implementend 2018-05-03 Refactor structure function assignment for NLO 2018-05-02 FKS slicing parameter xi_cut, delta_0 implemented 2018-04-20 Workspace subdirectory for process integration (grid/phs files) Packing/unpacking of files at job end/start Exporting integration results from scan loops 2018-04-13 Extended QCD NLO test suite 2018-04-09 Bug fix for Higgs Singlet Extension model 2018-04-06 Workspace subdirectory for process generation and compilation --job-id option for creating job-specific names 2018-03-20 Bug fix for color flow matching in hadron collisions with identical initial state quarks 2018-03-08 Structure functions quantum numbers correctly assigned for NLO 2018-02-24 Configure setup includes 'pgfortran' and 'flang' 2018-02-21 Include spin-correlated matrix elements in interactions 2018-02-15 Separate module for QED ISR structure functions ################################################################## 2018-02-10 RELEASE: version 2.6.3 2018-02-08 Improvements in memory management for PS generation 2018-01-31 Partial refactoring: quantum number assigment NLO Initial-state QCD splittings for hadron collisions 2018-01-25 Bug fix for weighted events with VAMP2 2018-01-17 Generalized interface for Recola versions 1.3+ and 2.1+ 2018-01-15 Channel equivalences also for VAMP2 integrator 2018-01-12 Fix for OCaml compiler 4.06 (and newer) 2017-12-19 RECOLA matrix elements with flavor sums can be integrated 2017-12-18 Bug fix for segmentation fault in empty resonance histories 2017-12-16 Fixing a bug in PYTHIA6 PYHEPC routine by omitting CMShowers from transferral between PYTHIA and WHIZARD event records 2017-12-15 Event index for multiple processes in event file correct ################################################################## 2017-12-13 RELEASE: version 2.6.2 2017-12-07 User can set offset in event numbers 2017-11-29 Possibility to have more than one RECOLA process in one file 2017-11-23 Transversal/mixed (and unitarized) dim-8 operators 2017-11-16 epa_q_max replaces epa_e_max (trivial factor 2) 2017-11-15 O'Mega matrix element compilation silent now 2017-11-14 Complete expanded P-wave form factor for top threshold 2017-11-10 Incoming particles can be accessed in SINDARIN 2017-11-08 Improved handling of resonance insertion, additional parameters 2017-11-04 Added Higgs-electron coupling (SM_Higgs) ################################################################## 2017-11-03 RELEASE: version 2.6.1 2017-10-20 More than 5 NLO components possible at same time 2017-10-19 Gaussian cutoff for shower resonance matching 2017-10-12 Alternative (more efficient) method to generate phase space file 2017-10-11 Bug fix for shower resonance histories for processes with multiple components 2017-09-25 Bug fix for process libraries in shower resonance histories 2017-09-21 Correctly generate pT distribution for EPA remnants 2017-09-20 Set branching ratios for unstable particles also by hand 2017-09-14 Correctly generate pT distribution for ISR photons ################################################################## 2017-09-08 RELEASE: version 2.6.0 2017-09-05 Bug fix for initial state NLO QCD flavor structures Real and virtual NLO QCD hadron collider processes work with internal interactions 2017-09-04 Fully validated MPI integration and event generation 2017-09-01 Resonance histories for shower: full support Bug fix in O'Mega model constraints O'Mega allows to output a parsable form of the DAG 2017-08-24 Resonance histories in events for transferral to parton shower (e.g. in ee -> jjjj) 2017-08-01 Alpha version of HepMC v3 interface (not yet really functional) 2017-07-31 Beta version for RECOLA OLP support 2017-07-06 Radiation generator fix for LHC processes 2017-06-30 Fix bug for NLO with structure functions and/or polarization 2017-06-23 Collinear limit for QED corrections works 2017-06-17 POWHEG grids generated already during integration 2017-06-12 Soft limit for QED corrections works 2017-05-16 Beta version of full MPI parallelization (VAMP2) Check consistency of POWHEG grid files Logfile config-summary.log for configure summary 2017-05-12 Allow polarization in top threshold 2017-05-09 Minimal demand automake 1.12.2 Silent rules for make procedures 2017-05-07 Major fix for POWHEG damping Correctly initialize FKS ISR phasespace ################################################################## 2017-05-06 RELEASE: version 2.5.0 2017-05-05 Full UFO support (SM-like models) Fixed-beam ISR FKS phase space 2017-04-26 QED splittings in radiation generator 2017-04-10 Retire deprecated O'Mega vertex cache files ################################################################## 2017-03-24 RELEASE: version 2.4.1 2017-03-16 Distinguish resonance charge in phase space channels Keep track of resonance histories in phase space Complex mass scheme default for OpenLoops amplitudes 2017-03-13 Fix helicities for polarized OpenLoops calculations 2017-03-09 Possibility to advance RNG state in rng_stream 2017-03-04 General setup for partitioning real emission phase space 2017-03-06 Bug fix on rescan command for converting event files 2017-02-27 Alternative multi-channel VEGAS implementation VAMP2: serial backbone for MPI setup Smoothstep top threshold matching 2017-02-25 Single-beam structure function with s-channel mapping supported Safeguard against invalid process libraries 2017-02-16 Radiation generator for photon emission 2017-02-10 Fixes for NLO QCD processes (color correlations) 2017-01-16 LCIO variable takes precedence over LCIO_DIR 2017-01-13 Alternative random number generator rng_stream (cf. L'Ecuyer et al.) 2017-01-01 Fix for multi-flavor BLHA tree matrix elements 2016-12-31 Grid path option for VAMP grids 2016-12-28 Alpha version of Recola OLP support 2016-12-27 Dalitz plots for FKS phase space 2016-12-14 NLO multi-flavor events possible 2016-12-09 LCIO event header information added 2016-12-02 Alpha version of RECOLA interface Bug fix for generator status in LCIO ################################################################## 2016-11-28 RELEASE: version 2.4.0 2016-11-24 Bug fix for OpenLoops interface: EW scheme is set by WHIZARD Bug fixes for top threshold implementation 2016-11-11 Refactoring of dispatching 2016-10-18 Bug fix for LCIO output 2016-10-10 First implementation for collinear soft terms 2016-10-06 First full WHIZARD models from UFO files 2016-10-05 WHIZARD does not support legacy gcc 4.7.4 any longer 2016-09-30 Major refactoring of process core and NLO components 2016-09-23 WHIZARD homogeneous entity: discarding subconfigures for CIRCE1/2, O'Mega, VAMP subpackages; these are reconstructable by script projectors 2016-09-06 Introduce main configure summary 2016-08-26 Fix memory leak in event generation ################################################################## 2016-08-25 RELEASE: version 2.3.1 2016-08-19 Bug fix for EW-scheme dependence of gluino propagators 2016-08-01 Beta version of complex mass scheme support 2016-07-26 Fix bug in POWHEG damping for the matching ################################################################## 2016-07-21 RELEASE: version 2.3.0 2016-07-20 UFO file support (alpha version) in O'Mega 2016-07-13 New (more) stable of WHIZARD GUI Support for EW schemes for OpenLoops Factorized NLO top decays for threshold model 2016-06-15 Passing factorization scale to PYTHIA6 Adding charge and neutral observables 2016-06-14 Correcting angular distribution/tweaked kinematics in non-collinear structure functions splittings 2016-05-10 Include (Fortran) TAUOLA/PHOTOS for tau decays via PYTHIA6 (backwards validation of LC CDR/TDR samples) 2016-04-27 Within OpenLoops virtuals: support for Collier library 2016-04-25 O'Mega vertex tables only loaded at first usage 2016-04-21 New CJ15 PDF parameterizations added 2016-04-21 Support for hadron collisions at NLO QCD 2016-04-05 Support for different (parameter) schemes in model files 2016-03-31 Correct transferral of lifetime/vertex from PYTHIA/TAUOLA into the event record 2016-03-21 New internal implementation of polarization via Bloch vectors, remove pointer constructions 2016-03-13 Extension of cascade syntax for processes: exclude propagators/vertices etc. possible 2016-02-24 Full support for OpenLoops QCD NLO matrix elements, inclusion in test suite 2016-02-12 Substantial progress on QCD NLO support 2016-02-02 Automated resonance mapping for FKS subtraction 2015-12-17 New BSM model WZW for diphoton resonances ################################################################## 2015-11-22 RELEASE: version 2.2.8 2015-11-21 Bug fix for fixed-order NLO events 2015-11-20 Anomalous FCNC top-charm vertices 2015-11-19 StdHEP output via HEPEVT/HEPEV4 supported 2015-11-18 Full set of electroweak dim-6 operators included 2015-10-22 Polarized one-loop amplitudes supported 2015-10-21 Fixes for event formats for showered events 2015-10-14 Callback mechanism for event output 2015-09-22 Bypass matrix elements in pure event sample rescans StdHep frozen final version v5.06.01 included internally 2015-09-21 configure option --with-precision to demand 64bit, 80bit, or 128bit Fortran and bind C precision types 2015-09-07 More extensive tests of NLO infrastructure and POWHEG matching 2015-09-01 NLO decay infrastructure User-defined squared matrix elements Inclusive FastJet algorithm plugin Numerical improvement for small boosts ################################################################## 2015-08-11 RELEASE: version 2.2.7 2015-08-10 Infrastructure for damped POWHEG Massive emitters in POWHEG Born matrix elements via BLHA GoSam filters via SINDARIN Minor running coupling bug fixes Fixed-order NLO events 2015-08-06 CT14 PDFs included (LO, NLO, NNLL) 2015-07-07 Revalidation of ILC WHIZARD-PYTHIA event chain Extended test suite for showered events Alpha version of massive FSR for POWHEG 2015-06-09 Fix memory leak in interaction for long cascades Catch mismatch between beam definition and CIRCE2 spectrum 2015-06-08 Automated POWHEG matching: beta version Infrastructure for GKS matching Alpha version of fixed-order NLO events CIRCE2 polarization averaged spectra with explicitly polarized beams 2015-05-12 Abstract matching type: OO structure for matching/merging 2015-05-07 Bug fix in event record WHIZARD-PYTHIA6 transferral Gaussian beam spectra for lepton colliders ################################################################## 2015-05-02 RELEASE: version 2.2.6 2015-05-01 Models for (unitarized) tensor resonances in VBS 2015-04-28 Bug fix in channel weights for event generation. 2015-04-18 Improved event record transfer WHIZARD/PYTHIA6 2015-03-19 POWHEG matching: alpha version ################################################################## 2015-02-27 RELEASE: version 2.2.5 2015-02-26 Abstract types for quantum numbers 2015-02-25 Read-in of StdHEP events, self-tests 2015-02-22 Bug fix for mother-daughter relations in showered/hadronized events 2015-02-20 Projection on polarization in intermediate states 2015-02-13 Correct treatment of beam remnants in event formats (also LC remnants) ################################################################## 2015-02-06 RELEASE: version 2.2.4 2015-02-06 Bug fix in event output 2015-02-05 LCIO event format supported 2015-01-30 Including state matrices in WHIZARD's internal IO Versioning for WHIZARD's internal IO Libtool update from 2.4.3 to 2.4.5 LCIO event output (beta version) 2015-01-27 Progress on NLO integration Fixing a bug for multiple processes in a single event file when using beam event files 2015-01-19 Bug fix for spin correlations evaluated in the rest frame of the mother particle 2015-01-17 Regression fix for statically linked processes from SARAH and FeynRules 2015-01-10 NLO: massive FKS emitters supported (experimental) 2015-01-06 MMHT2014 PDF sets included 2015-01-05 Handling mass degeneracies in auto_decays 2014-12-19 Fixing bug in rescan of event files ################################################################## 2014-11-30 RELEASE: version 2.2.3 2014-11-29 Beta version of LO continuum/NLL-threshold matched top threshold model for e+e- physics 2014-11-28 More internal refactoring: disentanglement of module dependencies 2014-11-21 OVM: O'Mega Virtual Machine, bytecode instructions instead of compiled Fortran code 2014-11-01 Higgs Singlet extension model included 2014-10-18 Internal restructuring of code; half-way WHIZARD main code file disassembled 2014-07-09 Alpha version of NLO infrastructure ################################################################## 2014-07-06 RELEASE: version 2.2.2 2014-07-05 CIRCE2: correlated LC beam spectra and GuineaPig Interface to LC machine parameters 2014-07-01 Reading LHEF for decayed/factorized/showered/ hadronized events 2014-06-25 Configure support for GoSAM/Ninja/Form/QGraf 2014-06-22 LHAPDF6 interface 2014-06-18 Module for automatic generation of radiation and loop infrastructure code 2014-06-11 Improved internal directory structure ################################################################## 2014-06-03 RELEASE: version 2.2.1 2014-05-30 Extensions of internal PDG arrays 2014-05-26 FastJet interface 2014-05-24 CJ12 PDFs included 2014-05-20 Regression fix for external models (via SARAH or FeynRules) ################################################################## 2014-05-18 RELEASE: version 2.2.0 2014-04-11 Multiple components: inclusive process definitions, syntax: process A + B + ... 2014-03-13 Improved PS mappings for e+e- ISR ILC TDR and CLIC spectra included in CIRCE1 2014-02-23 New models: AltH w\ Higgs for exclusion purposes, SM_rx for Dim 6-/Dim-8 operators, SSC for general strong interactions (w/ Higgs), and NoH_rx (w\ Higgs) 2014-02-14 Improved s-channel mapping, new on-shell production mapping (e.g. Drell-Yan) 2014-02-03 PRE-RELEASE: version 2.2.0_beta 2014-01-26 O'Mega: Feynman diagram generation possible (again) 2013-12-16 HOPPET interface for b parton matching 2013-11-15 PRE-RELEASE: version 2.2.0_alpha-4 2013-10-27 LHEF standards 1.0/2.0/3.0 implemented 2013-10-15 PRE-RELEASE: version 2.2.0_alpha-3 2013-10-02 PRE-RELEASE: version 2.2.0_alpha-2 2013-09-25 PRE-RELEASE: version 2.2.0_alpha-1 2013-09-12 PRE-RELEASE: version 2.2.0_alpha 2013-09-03 General 2HDM implemented 2013-08-18 Rescanning/recalculating events 2013-06-07 Reconstruction of complete event from 4-momenta possible 2013-05-06 Process library stacks 2013-05-02 Process stacks 2013-04-29 Single-particle phase space module 2013-04-26 Abstract interface for random number generator 2013-04-24 More object-orientation on modules Midpoint-rule integrator 2013-04-05 Object-oriented integration and event generation 2013-03-12 Processes recasted object-oriented: MEs, scales, structure functions First infrastructure for general Lorentz structures 2013-01-17 Object-orientated reworking of library and process core, more variable internal structure, unit tests 2012-12-14 Update Pythia version to 6.4.27 2012-12-04 Fix the phase in HAZ vertices 2012-11-21 First O'Mega unit tests, some infrastructure 2012-11-13 Bug fix in anom. HVV Lorentz structures ################################################################## 2012-09-18 RELEASE: version 2.1.1 2012-09-11 Model MSSM_Hgg with Hgg and HAA vertices 2012-09-10 First version of implementation of multiple interactions in WHIZARD 2012-09-05 Infrastructure for internal CKKW matching 2012-09-02 C, C++, Python API 2012-07-19 Fixing particle numbering in HepMC format ################################################################## 2012-06-15 RELEASE: version 2.1.0 2012-06-14 Analytical and kT-ordered shower officially released PYTHIA interface officially released 2012-05-09 Intrisince PDFs can be used for showering 2012-05-04 Anomalous Higgs couplings a la hep-ph/9902321 ################################################################## 2012-03-19 RELEASE: version 2.0.7 2012-03-15 Run IDs are available now More event variables in analysis Modified raw event format (compatibility mode exists) 2012-03-12 Bug fix in decay-integration order MLM matching steered completely internally now 2012-03-09 Special phase space mapping for narrow resonances decaying to 4-particle final states with far off-shell intermediate states Running alphas from PDF collaborations with builtin PDFs 2012-02-16 Bug fix in cascades decay infrastructure 2012-02-04 WHIZARD documentation compatible with TeXLive 2011 2012-02-01 Bug fix in FeynRules interface with --prefix flag 2012-01-29 Bug fix with name clash of O'Mega variable names 2012-01-27 Update internal PYTHIA to version 6.4.26 Bug fix in LHEF output 2012-01-21 Catching stricter automake 1.11.2 rules 2011-12-23 Bug fix in decay cascade setup 2011-12-20 Bug fix in helicity selection rules 2011-12-16 Accuracy goal reimplemented 2011-12-14 WHIZARD compatible with TeXLive 2011 2011-12-09 Option --user-target added ################################################################## 2011-12-07 RELEASE: version 2.0.6 2011-12-07 Bug fixes in SM_top_anom Added missing entries to HepMC format 2011-12-06 Allow to pass options to O'Mega Bug fix for HEPEVT block for showered/hadronized events 2011-12-01 Reenabled user plug-in for external code for cuts, structure functions, routines etc. 2011-11-29 Changed model SM_Higgs for Higgs phenomenology 2011-11-25 Supporting a Y, (B-L) Z' model 2011-11-23 Make WHIZARD compatible for MAC OS X Lion/XCode 4 2011-09-25 WHIZARD paper published: Eur.Phys.J. C71 (2011) 1742 2011-08-16 Model SM_QCD: QCD with one EW insertion 2011-07-19 Explicit output channel for dvips avoids printing 2011-07-10 Test suite for WHIZARD unit tests 2011-07-01 Commands for matrix element tests More OpenMP parallelization of kinematics Added unit tests 2011-06-23 Conversion of CIRCE2 from F77 to F90, major clean-up 2011-06-14 Conversion of CIRCE1 from F77 to F90 2011-06-10 OpenMP parallelization of channel kinematics (by Matthias Trudewind) 2011-05-31 RELEASE: version 1.97 2011-05-24 Minor bug fixes: update grids and elsif statement. ################################################################## 2011-05-10 RELEASE: version 2.0.5 2011-05-09 Fixed bug in final state flavor sums Minor improvements on phase-space setup 2011-05-05 Minor bug fixes 2011-04-15 WHIZARD as a precompiled 64-bit binary available 2011-04-06 Wall clock instead of cpu time for time estimates 2011-04-05 Major improvement on the phase space setup 2011-04-02 OpenMP parallelization for helicity loop in O'Mega matrix elements 2011-03-31 Tools for relocating WHIZARD and use in batch environments 2011-03-29 Completely static builds possible, profiling options 2011-03-28 Visualization of integration history 2011-03-27 Fixed broken K-matrix implementation 2011-03-23 Including the GAMELAN manual in the distribution 2011-01-26 WHIZARD analysis can handle hadronized event files 2011-01-17 MSTW2008 and CT10 PDF sets included 2010-12-23 Inclusion of NMSSM with Hgg couplings 2010-12-21 Advanced options for integration passes 2010-11-16 WHIZARD supports CTEQ6 and possibly other PDFs directly; data files included in the distribution ################################################################## 2010-10-26 RELEASE: version 2.0.4 2010-10-06 Bug fix in MSSM implementation 2010-10-01 Update to libtool 2.4 2010-09-29 Support for anomalous top couplings (form factors etc.) Bug fix for running gauge Yukawa SUSY couplings 2010-09-28 RELEASE: version 1.96 2010-09-21 Beam remnants and pT spectra for lepton collider re-enabled Restructuring subevt class 2010-09-16 Shower and matching are disabled by default PYTHIA as a conditional on these two options 2010-09-14 Possibility to read in beam spectra re-enabled (e.g. Guinea Pig) 2010-09-13 Energy scan as (pseudo-) structure functions re-implemented 2010-09-10 CIRCE2 included again in WHIZARD 2 and validated 2010-09-02 Re-implementation of asymmetric beam energies and collision angles, e-p collisions work, inclusion of a HERA DIS test case ################################################################## 2010-10-18 RELEASE: version 2.0.3 2010-08-08 Bug in CP-violating anomalous triple TGCs fixed 2010-08-06 Solving backwards compatibility problem with O'Caml 3.12.0 2010-07-12 Conserved quantum numbers speed up O'Mega code generation 2010-07-07 Attaching full ISR/FSR parton shower and MPI/ISR module Added SM model containing Hgg, HAA, HAZ vertices 2010-07-02 Matching output available as LHEF and STDHEP 2010-06-30 Various bug fixes, missing files, typos 2010-06-26 CIRCE1 completely re-enabled Chaining structure functions supported 2010-06-25 Partial support for conserved quantum numbers in O'Mega 2010-06-21 Major upgrade of the graphics package: error bars, smarter SINDARIN steering, documentation, and all that... 2010-06-17 MLM matching with PYTHIA shower included 2010-06-16 Added full CIRCE1 and CIRCE2 versions including full documentation and miscellanea to the trunk 2010-06-12 User file management supported, improved variable and command structure 2010-05-24 Improved handling of variables in local command lists 2010-05-20 PYTHIA interface re-enabled 2010-05-19 ASCII file formats for interfacing ROOT and gnuplot in data analysis ################################################################## 2010-05-18 RELEASE: version 2.0.2 2010-05-14 Reimplementation of visualization of phase space channels Minor bug fixes 2010-05-12 Improved phase space - elimination of redundancies 2010-05-08 Interface for polarization completed: polarized beams etc. 2010-05-06 Full quantum numbers appear in process log Integration results are usable as user variables Communication with external programs 2010-05-05 Split module commands into commands, integration, simulation modules 2010-05-04 FSR+ISR for the first time connected to the WHIZARD 2 core ################################################################## 2010-04-25 RELEASE: version 2.0.1 2010-04-23 Automatic compile and integrate if simulate is called Minor bug fixes in O'Mega 2010-04-21 Checkpointing for event generation Flush statements to use WHIZARD inside a pipe 2010-04-20 Reimplementation of signal handling in WGIZARD 2.0 2010-04-19 VAMP is now a separately configurable and installable unit of WHIZARD, included VAMP self-checks Support again compilation in quadruple precision 2010-04-06 Allow for logarithmic plots in GAMELAN, reimplement the possibility to set the number of bins 2010-04-15 Improvement on time estimates for event generation ################################################################## 2010-04-12 RELEASE: version 2.0.0 2010-04-09 Per default, the code for the amplitudes is subdivided to allow faster compiler optimization More advanced and unified and straightforward command language syntax Final bug fixes 2010-04-07 Improvement on SINDARIN syntax; printf, sprintf function thorugh a C interface 2010-04-05 Colorizing DAGs instead of model vertices: speed boost in colored code generation 2010-03-31 Generalized options for normalization of weighted and unweighted events Grid and weight histories added again to log files Weights can be used in analyses 2010-03-28 Cascade decays completely implemented including color and spin correlations 2010-03-07 Added new WHIZARD header with logo 2010-03-05 Removed conflict in O'Mega amplitudes between flavour sums and cascades StdHEP interface re-implemented 2010-03-03 RELEASE: version 2.0.0rc3 Several bug fixes for preventing abuse in input files OpenMP support for amplitudes Reimplementation of WHIZARD 1 HEPEVT ASCII event formats FeynRules interface successfully passed MSSM test 2010-02-26 Eliminating ghost gluons from multi-gluon amplitudes 2010-02-25 RELEASE: version 1.95 HEPEVT format from WHIZARD 1 re-implemented in WHIZARD 2 2010-02-23 Running alpha_s implemented in the FeynRules interface 2010-02-19 MSSM (semi-) automatized self-tests finalized 2010-02-17 RELEASE: version 1.94 2010-02-16 Closed memory corruption in WHIZARD 1 Fixed problems of old MadGraph and CompHep drivers with modern compilers Uncolored vertex selection rules for colored amplitudes in O'Mega 2010-02-15 Infrastructure for color correlation computation in O'Mega finished Forbidden processes are warned about, but treated as non-fatal 2010-02-14 Color correlation computation in O'Mega finalized 2010-02-10 Improving phase space mappings for identical particles in initial and final states Introduction of more extended multi-line error message 2010-02-08 First O'Caml code for computation of color correlations in O'Mega 2010-02-07 First MLM matching with e+ e- -> jets ################################################################## 2010-02-06 RELEASE: version 2.0.0rc2 2010-02-05 Reconsidered the Makefile structure and more extended tests Catch a crash between WHIZARD and O'Mega for forbidden processes Tensor products of arbitrary color structures in jet definitions 2010-02-04 Color correlation computation in O'Mega finalized ################################################################## 2010-02-03 RELEASE: version 2.0.0rc1 ################################################################## 2010-01-31 Reimplemented numerical helicity selection rules Phase space functionality of version 1 restored and improved 2009-12-05 NMSSM validated with FeynRules in WHIZARD 1 (Felix Braam) 2009-12-04 RELEASE: version 2.0.0alpha ################################################################## 2009-04-16 RELEASE: version 1.93 2009-04-15 Clean-up of Makefiles and configure scripts Reconfiguration of BSM model implementation extended supersymmetric models 2008-12-23 New model NMSSM (Felix Braam) SLHA2 added Bug in LHAPDF interface fixed 2008-08-16 Bug fixed in K matrix implementation Gravitino option in the MSSM added 2008-03-20 Improved color and flavor sums ################################################################## 2008-03-12 RELEASE: version 1.92 LHEF (Les Houches Event File) format added Fortran 2003 command-line interface (if supported by the compiler) Automated interface to colored models More bug fixes and workarounds for compiler compatibility ################################################################## 2008-03-06 RELEASE: version 1.91 New model K-matrix (resonances and anom. couplings in WW scattering) EWA spectrum Energy-scan pseudo spectrum Preliminary parton shower module (only from final-state quarks) Cleanup and improvements of configure process Improvements for O'Mega parameter files Quadruple precision works again More plotting options: lines, symbols, errors Documentation with PDF bookmarks enabled Various bug fixes 2007-11-29 New model UED ################################################################## 2007-11-23 RELEASE: version 1.90 O'Mega now part of the WHIZARD tree Madgraph/CompHEP disabled by default (but still usable) Support for LHAPDF (preliminary) Added new models: SMZprime, SM_km, Template Improved compiler recognition and compatibility Minor bug fixes ################################################################## 2006-06-15 RELEASE: version 1.51 Support for anomaly-type Higgs couplings (to gluon and photon/Z) Support for spin 3/2 and spin 2 New models: Little Higgs (4 versions), toy models for extra dimensions and gravitinos Fixes to the whizard.nw source documentation to run through LaTeX Intel 9.0 bug workaround (deallocation of some arrays) 2006-05-15 O'Mega RELEASE: version 0.11 merged JRR's O'Mega extensions ################################################################## 2006-02-07 RELEASE: version 1.50 To avoid confusion: Mention outdated manual example in BUGS file O'Mega becomes part of the WHIZARD generator 2006-02-02 [bug fix update] Bug fix: spurious error when writing event files for weighted events Bug fix: 'r' option for omega produced garbage for some particle names Workaround for ifort90 bug (crash when compiling whizard_event) Workaround for ifort90 bug (crash when compiling hepevt_common) 2006-01-27 Added process definition files for MSSM 2->2 processes Included beam recoil for EPA (T.Barklow) Updated STDHEP byte counts (for STDHEP 5.04.02) Fixed STDHEP compatibility (avoid linking of incomplete .so libs) Fixed issue with comphep requiring Xlibs on Opteron Fixed issue with ifort 8.x on Opteron (compiling 'signal' interface) Fixed color-flow code: was broken for omega with option 'c' and 'w' Workaround hacks for g95 compatibility 2005-11-07 O'Mega RELEASE: version 0.10 O'Mega, merged JRR's and WK's color hack for WHiZard O'Mega, EXPERIMENTAL: cache fusion tables (required for colors a la JRR/WK) O'Mega, make JRR's MSSM official ################################################################## 2005-10-25 RELEASE: version 1.43 Minor fixes in MSSM couplings (Higgs/3rd gen squarks). This should be final, since the MSSM results agree now completely with Madgraph and Sherpa User-defined lower and upper limits for split event file count Allow for counters (events, bytes) exceeding $2^{31}$ Revised checksum treatment and implementation (now MD5) Bug fix: missing process energy scale in raw event file ################################################################## 2005-09-30 RELEASE: version 1.42 Graphical display of integration history ('make history') Allow for switching off signals even if supported (configure option) 2005-09-29 Revised phase space generation code, in particular for flavor sums Negative cut and histogram codes use initial beams instead of initial parton momenta. This allows for computing, e.g., E_miss Support constant-width and zero-width options for O'Mega Width options now denoted by w:X (X=f,c,z). f option obsolescent Bug fix: colorized code: flipped indices could screw up result Bug fix: O'Mega with 'c' and 'w:f' option together (still some problem) Bug fix: dvips on systems where dvips defaults to lpr Bug fix: integer overflow if too many events are requested 2005-07-29 Allow for 2 -> 1 processes (if structure functions are on) 2005-07-26 Fixed and expanded the 'test' matrix element: Unit matrix element with option 'u' / default: normalized phase space ################################################################## 2005-07-15 RELEASE: version 1.41 Bug fix: no result for particle decay processes with width=0 Bug fix: line breaks in O'Mega files with color decomposition 2005-06-02 New self-tests (make test-QED / test-QCD / test-SM) check lists of 2->2 processes Bug fix: HELAS calling convention for wwwwxx and jwwwxx (4W-Vertex) 2005-05-25 Revised Makefile structure Eliminated obsolete references to ISAJET/SUSY (superseded by SLHA) 2005-05-19 Support for color in O'Mega (using color flow decomposition) New model QCD Parameter file changes that correspond to replaced SM module in O'Mega Bug fixes in MSSM (O'Mega) parameter file 2005-05-18 New event file formats, useful for LHC applications: ATHENA and Les Houches Accord (external fragmentation) Naive (i.e., leading 1/N) color factor now implemented both for incoming and outgoing partons 2005-01-26 include missing HELAS files for bundle pgf90 compatibility issues [note: still internal error in pgf90] ################################################################## 2004-12-13 RELEASE: version 1.40 compatibility fix: preprocessor marks in helas code now commented out minor bug fix: format string in madgraph source 2004-12-03 support for arbitray beam energies and directions allow for pT kick in structure functions bug fix: rounding error could result in zero cross section (compiler-dependent) 2004-10-07 simulate decay processes list fraction (of total width/cross section) instead of efficiency in process summary new cut/analysis parameters AA, AAD, CTA: absolute polar angle 2004-10-04 Replaced Madgraph I by Madgraph II. Main improvement: model no longer hardcoded introduced parameter reset_seed_each_process (useful for debugging) bug fix: color initialization for some processes was undefined 2004-09-21 don't compile unix_args module if it is not required ################################################################## 2004-09-20 RELEASE: version 1.30 g95 compatibility issues resolved some (irrelevant) memory leaks closed removed obsolete warning in circe1 manual update (essentially) finished 2004-08-03 O'Mega RELEASE: version 0.9 O'Mega, src/trie.mli, src/trie.ml: make interface compatible with the O'Caml 3.08 library (remains compatible with older versions). Implementation of unused functions still incomplete. 2004-07-26 minor fixes and improvements in make process 2004-06-29 workarounds for new Intel compiler bugs ... no rebuild of madgraph/comphep executables after 'make clean' bug fix in phase space routine: wrong energy for massive initial particles bug fix in (new) model interface: name checks for antiparticles pre-run checks for comphep improved ww-strong model file extended Model files particle name fixes, chep SM vertices included 2004-06-22 O'Mega RELEASE: version 0.8 O'Mega MSSM: sign of W+/W-/A and W+/W-/Z couplings 2004-05-05 Fixed bug in PDFLIB interface: p+pbar was initialized as p+p (ThO) NAG compiler: set number of continuation lines to 200 as default Extended format for cross section summary; appears now in whizard.out Fixed 'bundle' feature 2004-04-28 Fixed compatibility with revised O'Mega SM_ac model Fixed problem with x=0 or x=1 when calling PDFLIB (ThO) Fixed bug in comphep module: Vtb was overlooked ################################################################## 2004-04-15 RELEASE: version 1.28 Fixed bug: Color factor was missing for O'Mega processes with four quarks and more Manual partially updated 2004-04-08 Support for grid files in binary format New default value show_histories=F (reduce output file size) Revised phase space switches: removed annihilation_lines, removed s_channel_resonance, changed meaning of extra_off_shell_lines, added show_deleted_channels Bug fixed which lead to omission of some phase space channels Color flow guessed only if requested by guess_color_flow 2004-03-10 New model interface: Only one model name specified in whizard.prc All model-dependent files reside in conf/models (modellib removed) 2004-03-03 Support for input/output in SUSY Les Houches Accord format Split event files if requested Support for overall time limit Support for CIRCE and CIRCE2 generator mode Support for reading beam events from file 2004-02-05 Fixed compiler problems with Intel Fortran 7.1 and 8.0 Support for catching signals ################################################################## 2003-08-06 RELEASE: version 1.27 User-defined PDF libraries as an alternative to the standard PDFLIB 2003-07-23 Revised phase space module: improved mappings for massless particles, equivalences of phase space channels are exploited Improved mapping for PDF (hadron colliders) Madgraph module: increased max number of color flows from 250 to 1000 ################################################################## 2003-06-23 RELEASE: version 1.26 CIRCE2 support Fixed problem with 'TC' integer kind [Intel compiler complained] 2003-05-28 Support for drawing histograms of grids Bug fixes for MSSM definitions ################################################################## 2003-05-22 RELEASE: version 1.25 Experimental MSSM support with ISAJET interface Improved capabilities of generating/analyzing weighted events Optional drawing phase space diagrams using FeynMF ################################################################## 2003-01-31 RELEASE: version 1.24 A few more fixes and workarounds (Intel and Lahey compiler) 2003-01-15 Fixes and workarounds needed for WHIZARD to run with Intel compiler Command-line option interface for the Lahey compiler Bug fix: problem with reading whizard.phs ################################################################## 2002-12-10 RELEASE: version 1.23 Command-line options (on some systems) Allow for initial particles in the event record, ordered: [beams, initials] - [remnants] - outgoing partons Support for PYTHIA 6.2: Les Houches external process interface String pythia_parameters can be up to 1000 characters long Select color flow states in (internal) analysis Bug fix in color flow content of raw event files Support for transversal polarization of fermion beams Cut codes: PHI now for absolute azimuthal angle, DPHI for distance 'Test' matrix elements optionally respect polarization User-defined code can be inserted for spectra, structure functions and fragmentation Time limits can be specified for adaptation and simulation User-defined file names and file directory Initial weights in input file no longer supported Bug fix in MadGraph (wave function counter could overflow) Bug fix: Gamelan (graphical analysis) was not built if noweb absent ################################################################## 2002-03-16 RELEASE: version 1.22 Allow for beam remnants in the event record 2002-03-01 Handling of aliases in whizard.prc fixed (aliases are whole tokens) 2002-02-28 Optimized phase space handling routines (total execution time reduced by 20-60%, depending on process) ################################################################## 2002-02-26 RELEASE: version 1.21 Fixed ISR formula (ISR was underestimated in previous versions). New version includes ISR in leading-log approximation up to third order. Parameter ISR_sqrts renamed to ISR_scale. ################################################################## 2002-02-19 RELEASE: version 1.20 New process-generating method 'test' (dummy matrix element) Compatibility with autoconf 2.50 and current O'Mega version 2002-02-05 Prevent integration channels from being dropped (optionally) New internal mapping for structure functions improves performance Old whizard.phx file deleted after recompiling (could cause trouble) 2002-01-24 Support for user-defined cuts and matrix element reweighting STDHEP output now written by write_events_format=20 (was 3) 2002-01-16 Improved structure function handling; small changes in user interface: new parameter structured_beams in &process_input parameter fixed_energy in &beam_input removed Support for multiple initial states Eta-phi (cone) cut possible (hadron collider applications) Fixed bug: Whizard library was not always recompiled when necessary Fixed bug: Default cuts were insufficient in some cases Fixed bug: Unusable phase space mappings generated in some cases 2001-12-06 Reorganized document source 2001-12-05 Preliminary CIRCE2 support (no functionality yet) 2001-11-27 Intel compiler support (does not yet work because of compiler bugs) New cut and analysis mode cos-theta* and related Fixed circular jetset_interface dependency warning Some broadcast routines removed (parallel support disabled anyway) Minor shifts in cleanup targets (Makefiles) Modified library search, check for pdflib8* 2001-08-06 Fixed bug: I/O unit number could be undefined when reading phase space Fixed bug: Unitialized variable could cause segfault when event generation was disabled Fixed bug: Undefined subroutine in CIRCE replacement module Enabled feature: TGCs in O'Mega (not yet CompHEP!) matrix elements (CompHEP model sm-GF #5, O'Mega model SM_ac) Fixed portability issue: Makefile did rely on PWD environment variable Fixed portability issue: PYTHIA library search ambiguity resolved 2001-08-01 Default whizard.prc and whizard.in depend on activated modules Fixed bug: TEX=latex was not properly enabled when making plots 2001-07-20 Fixed output settings in PERL script calls Cache enabled in various configure checks 2001-07-13 Support for multiple processes in a single WHIZARD run. The integrations are kept separate, but the generated events are mixed The whizard.evx format has changed (incompatible), including now the color flow information for PYTHIA fragmentation Output files are now process-specific, except for the event file Phase space file whizard.phs (if present) is used only as input, program-generated phase space is now in whizard.phx 2001-07-10 Bug fix: Undefined parameters in parameters_SM_ac.f90 removed 2001-07-04 Bug fix: Compiler options for the case OMEGA is disabled Small inconsistencies in whizard.out format fixed 2001-07-01 Workaround for missing PDFLIB dummy routines in PYTHIA library ################################################################## 2001-06-30 RELEASE: version 1.13 Default path /cern/pro/lib in configure script 2001-06-20 New fragmentation option: Interface for PYTHIA with full color flow information, beam remnants etc. 2001-06-18 Severe bug fixed in madgraph interface: 3-gluon coupling was missing Enabled color flow information in madgraph 2001-06-11 VAMP interface module rewritten Revised output format: Multiple VAMP iterations count as one WHIZARD iteration in integration passes 1 and 3 Improved message and error handling Bug fix in VAMP: handle exceptional cases in rebinning_weights 2001-05-31 new parameters for grid adaptation: accuracy_goal and efficiency_goal ################################################################## 2001-05-29 RELEASE: version 1.12 bug fixes (compilation problems): deleted/modified unused functions 2001-05-16 diagram selection improved and documented 2001-05-06 allow for disabling packages during configuration 2001-05-03 slight changes in whizard.out format; manual extended ################################################################## 2001-04-20 RELEASE: version 1.11 fixed some configuration and compilation problems (PDFLIB etc.) 2001-04-18 linked PDFLIB: support for quark/gluon structure functions 2001-04-05 parameter interface written by PERL script SM_ac model file: fixed error in continuation line 2001-03-13 O'Mega, O'Caml 3.01: incompatible changes O'Mega, src/trie.mli: add covariance annotation to T.t This breaks O'Caml 3.00, but is required for O'Caml 3.01. O'Mega, many instances: replace `sig include Module.T end' by `Module.T', since the bug is fixed in O'Caml 3.01 2001-02-28 O'Mega, src/model.mli: new field Model.vertices required for model functors, will retire Model.fuse2, Model.fuse3, Model.fusen soon. ################################################################## 2001-03-27 RELEASE: version 1.10 reorganized the modules as libraries linked PYTHIA: support for parton fragmentation 2000-12-14 fixed some configuration problems (if noweb etc. are absent) ################################################################## 2000-12-01 RELEASE of first public version: version 1.00beta Index: trunk/src/threshold/threshold.nw =================================================================== --- trunk/src/threshold/threshold.nw (revision 8477) +++ trunk/src/threshold/threshold.nw (revision 8478) @@ -1,11176 +1,11176 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD threshold code as NOWEB source: threshold %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Infrastructure for threshold processes} \includemodulegraph{threshold} <<[[interpolation.f90]]>>= <> module interpolation use kinds implicit none save private public :: interpolate_linear, strictly_monotonous interface interpolate_linear module procedure interpolate_linear_1D_complex_array, & interpolate_linear_1D_complex_scalar, & interpolate_linear_1D_real_array, & interpolate_linear_1D_real_scalar, & interpolate_linear_2D_complex_array, & interpolate_linear_2D_complex_scalar, & interpolate_linear_2D_real_array, & interpolate_linear_2D_real_scalar, & interpolate_linear_3D_complex_array, & interpolate_linear_3D_complex_scalar, & interpolate_linear_3D_real_array, & interpolate_linear_3D_real_scalar end interface interface strictly_monotonous module procedure monotonous end interface strictly_monotonous interface find_nearest_left !!! recursive bisection is slower module procedure find_nearest_left_loop end interface find_nearest_left contains pure subroutine interpolate_linear_1D_complex_scalar (xa, ya, x, y) real(default), dimension(:), intent(in) :: xa complex(default), dimension(:), intent(in) :: ya real(default), intent(in) :: x complex(default), intent(out) :: y integer :: ixl real(default) :: t y = 0.0_default !!! don't check this at runtime: ! if ( .not.monotonous(xa) ) return if ( out_of_range(xa, x) ) return ixl = 0 call find_nearest_left (xa, x, ixl) t = ( x - xa(ixl) ) / ( xa(ixl+1) - xa(ixl) ) y = (1.-t)*ya(ixl) + t*ya(ixl+1) end subroutine interpolate_linear_1D_complex_scalar pure subroutine interpolate_linear_2D_complex_scalar (x1a, x2a, ya, x1, x2, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a complex(default), dimension(:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 complex(default), intent(out) :: y integer :: ix1l, ix2l real(default) :: t, u y = 0.0_default !!! don't check this at runtime: ! if ( (.not.monotonous(x1a)) .or. (.not.monotonous(x2a)) ) return if ( out_of_range(x1a, x1) .or. out_of_range(x2a, x2) ) return ix1l = 0 call find_nearest_left (x1a, x1, ix1l) ix2l = 0 call find_nearest_left (x2a, x2, ix2l) t = ( x1 - x1a(ix1l) ) / ( x1a(ix1l+1) - x1a(ix1l) ) u = ( x2 - x2a(ix2l) ) / ( x2a(ix2l+1) - x2a(ix2l) ) y = (1.-t)*(1.-u)*ya(ix1l ,ix2l ) & + t *(1.-u)*ya(ix1l+1,ix2l ) & + t * u *ya(ix1l+1,ix2l+1) & +(1.-t)* u *ya(ix1l ,ix2l+1) end subroutine interpolate_linear_2D_complex_scalar pure subroutine interpolate_linear_3D_complex_scalar (x1a, x2a, x3a, ya, x1, x2, x3, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a real(default), dimension(:), intent(in) :: x3a complex(default), dimension(:,:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 real(default), intent(in) :: x3 complex(default), intent(out) :: y integer :: ix1l, ix2l, ix3l real(default) :: t, u, v y = 0.0_default !!! don't check this at runtime: ! if ( (.not.monotonous(x1a)) .or. (.not.monotonous(x2a)) ) return if ( out_of_range(x1a, x1) .or. out_of_range(x2a, x2) .or. out_of_range(x3a, x3) ) return ix1l = 0 call find_nearest_left (x1a, x1, ix1l) ix2l = 0 call find_nearest_left (x2a, x2, ix2l) ix3l = 0 call find_nearest_left (x3a, x3, ix3l) t = ( x1 - x1a(ix1l) ) / ( x1a(ix1l+1) - x1a(ix1l) ) u = ( x2 - x2a(ix2l) ) / ( x2a(ix2l+1) - x2a(ix2l) ) v = ( x3 - x3a(ix3l) ) / ( x3a(ix3l+1) - x3a(ix3l) ) y = (1.-t)*(1.-u)*(1.-v)*ya(ix1l ,ix2l ,ix3l ) & +(1.-t)*(1.-u)* v *ya(ix1l ,ix2l ,ix3l+1) & +(1.-t)* u *(1.-v)*ya(ix1l ,ix2l+1,ix3l ) & +(1.-t)* u * v *ya(ix1l ,ix2l+1,ix3l+1) & + t *(1.-u)*(1.-v)*ya(ix1l+1,ix2l ,ix3l ) & + t *(1.-u)* v *ya(ix1l+1,ix2l ,ix3l+1) & + t * u *(1.-v)*ya(ix1l+1,ix2l+1,ix3l ) & + t * u * v *ya(ix1l+1,ix2l+1,ix3l+1) end subroutine interpolate_linear_3D_complex_scalar pure subroutine find_nearest_left_loop (xa, x, ixl) real(default), dimension(:), intent(in) :: xa real(default), intent(in) :: x integer, intent(out) :: ixl integer :: ixm, ixr ixl = 1 ixr = size(xa) do if ( ixr-ixl <= 1 ) return ixm = (ixr+ixl) / 2 if ( x < xa(ixm) ) then ixr = ixm else ixl = ixm end if end do end subroutine find_nearest_left_loop pure recursive subroutine find_nearest_left_rec (xa, x, ixl) real(default), dimension(:), intent(in) :: xa real(default), intent(in) :: x integer, intent(inout) :: ixl integer :: nx, bs real(default), dimension(:), allocatable :: xa_new nx = size(xa) bs = nx/2 + 1 if ( nx < 3 ) then ixl = ixl + bs - 1 return else if ( x < xa(bs) ) then allocate( xa_new(1:bs) ) xa_new = xa(1:bs) else ixl = ixl + bs - 1 allocate( xa_new(bs:nx) ) xa_new = xa(bs:nx) end if call find_nearest_left_rec (xa_new, x, ixl) deallocate( xa_new ) end if end subroutine find_nearest_left_rec pure function monotonous (xa) result (flag) real(default), dimension(:), intent(in) :: xa integer :: ix logical :: flag flag = .false. do ix = 1, size(xa)-1 flag = ( xa(ix) < xa(ix+1) ) if ( .not. flag ) return end do end function monotonous pure function out_of_range (xa, x) result (flag) real(default), dimension(:), intent(in) :: xa real(default), intent(in) :: x logical :: flag flag = ( x < xa(1) .or. x > xa(size(xa)) ) end function out_of_range pure subroutine interpolate_linear_1D_complex_array (xa, ya, x, y) real(default), dimension(:), intent(in) :: xa complex(default), dimension(:,:), intent(in) :: ya real(default), intent(in) :: x complex(default), dimension(size(ya(1,:))), intent(out) :: y integer :: iy do iy=1, size(y) call interpolate_linear_1D_complex_scalar (xa, ya(:,iy), x, y(iy)) end do end subroutine interpolate_linear_1D_complex_array pure subroutine interpolate_linear_1D_real_array (xa, ya, x, y) real(default), dimension(:), intent(in) :: xa real(default), dimension(:,:), intent(in) :: ya real(default), intent(in) :: x real(default), dimension(:), intent(out) :: y complex(default), dimension(size(ya(1,:))) :: y_c call interpolate_linear_1D_complex_array (xa, cmplx(ya,kind=default), x, y_c) y = real(y_c,kind=default) end subroutine interpolate_linear_1D_real_array pure subroutine interpolate_linear_1D_real_scalar (xa, ya, x, y) real(default), dimension(:), intent(in) :: xa real(default), dimension(:), intent(in) :: ya real(default), intent(in) :: x real(default), intent(out) :: y complex(default), dimension(size(ya)) :: ya_c complex(default) :: y_c ya_c = cmplx(ya,kind=default) call interpolate_linear_1D_complex_scalar (xa, ya_c, x, y_c) y = real(y_c,kind=default) end subroutine interpolate_linear_1D_real_scalar pure subroutine interpolate_linear_2D_complex_array (x1a, x2a, ya, x1, x2, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a complex(default), dimension(:,:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 complex(default), dimension(size(ya(1,1,:))), intent(out) :: y integer :: iy do iy=1, size(y) call interpolate_linear_2D_complex_scalar (x1a, x2a, ya(:,:,iy), x1, x2, y(iy)) end do end subroutine interpolate_linear_2D_complex_array pure subroutine interpolate_linear_2D_real_array (x1a, x2a, ya, x1, x2, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a real(default), dimension(:,:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 real(default), dimension(:), intent(out) :: y complex(default), dimension(size(ya(1,1,:))) :: y_c call interpolate_linear_2D_complex_array (x1a, x2a, cmplx(ya,kind=default), x1, x2, y_c) y = real(y_c,kind=default) end subroutine interpolate_linear_2D_real_array pure subroutine interpolate_linear_2D_real_scalar (x1a, x2a, ya, x1, x2, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a real(default), dimension(:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 real(default), intent(out) :: y complex(default), dimension(size(ya(:,1)),size(ya(1,:))) :: ya_c complex(default) :: y_c ya_c = reshape (ya_c, shape(ya)) ya_c = cmplx(ya,kind=default) call interpolate_linear_2D_complex_scalar (x1a, x2a, ya_c, x1, x2, y_c) y = real(y_c,kind=default) end subroutine interpolate_linear_2D_real_scalar pure subroutine interpolate_linear_3D_complex_array (x1a, x2a, x3a, ya, x1, x2, x3, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a real(default), dimension(:), intent(in) :: x3a complex(default), dimension(:,:,:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 real(default), intent(in) :: x3 complex(default), dimension(size(ya(1,1,1,:))), intent(out) :: y integer :: iy do iy=1, size(y) call interpolate_linear_3D_complex_scalar & (x1a, x2a, x3a, ya(:,:,:,iy), x1, x2, x3, y(iy)) end do end subroutine interpolate_linear_3D_complex_array pure subroutine interpolate_linear_3D_real_array (x1a, x2a, x3a, ya, x1, x2, x3, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a real(default), dimension(:), intent(in) :: x3a real(default), dimension(:,:,:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 real(default), intent(in) :: x3 real(default), dimension(:), intent(out) :: y complex(default), dimension(size(ya(1,1,1,:))) :: y_c call interpolate_linear_3D_complex_array & (x1a, x2a, x3a, cmplx(ya,kind=default), x1, x2, x3, y_c) y = real(y_c,kind=default) end subroutine interpolate_linear_3D_real_array pure subroutine interpolate_linear_3D_real_scalar (x1a, x2a, x3a, ya, x1, x2, x3, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a real(default), dimension(:), intent(in) :: x3a real(default), dimension(:,:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 real(default), intent(in) :: x3 real(default), intent(out) :: y complex(default), dimension(size(ya(:,1,1)),size(ya(1,:,1)),size(ya(1,1,:))) :: ya_c complex(default) :: y_c ya_c = cmplx(ya,kind=default) call interpolate_linear_3D_complex_scalar (x1a, x2a, x3a, ya_c, x1, x2, x3, y_c) y = real(y_c,kind=default) end subroutine interpolate_linear_3D_real_scalar end module interpolation @ <<[[nr_tools.f90]]>>= !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! WHIZARD <> <> ! routine hypgeo and other useful procedures from: ! ! Numerical Recipes in Fortran 77 and 90 (Second Edition) ! ! Book and code Copyright (c) 1986-2001, ! William H. Press, Saul A. Teukolsky, ! William T. Verrerling, Brian P. Flannery. ! ! Information at http://www.nr.com ! ! ! ! FB: -replaced tabs by 2 whitespaces ! -reduced hardcoded default stepsize for subroutine 'odeint' ! called by hypgeo, cf. line 4751 ! -added explicit interface for function 'qgaus' to main module 'nr' ! -renamed function 'locate' to 'locatenr' to avoid segfault (???) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MODULE nrtype INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9) INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4) INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2) INTEGER, PARAMETER :: SP = KIND(1.0) INTEGER, PARAMETER :: DP = KIND(1.0D0) INTEGER, PARAMETER :: SPC = KIND((1.0,1.0)) INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0)) INTEGER, PARAMETER :: LGT = KIND(.true.) REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_sp REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_sp REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp TYPE sprs2_sp INTEGER(I4B) :: n,len REAL(SP), DIMENSION(:), POINTER :: val INTEGER(I4B), DIMENSION(:), POINTER :: irow INTEGER(I4B), DIMENSION(:), POINTER :: jcol END TYPE sprs2_sp TYPE sprs2_dp INTEGER(I4B) :: n,len REAL(DP), DIMENSION(:), POINTER :: val INTEGER(I4B), DIMENSION(:), POINTER :: irow INTEGER(I4B), DIMENSION(:), POINTER :: jcol END TYPE sprs2_dp END MODULE nrtype MODULE nrutil USE nrtype IMPLICIT NONE INTEGER(I4B), PARAMETER :: NPAR_ARTH=16,NPAR2_ARTH=8 INTEGER(I4B), PARAMETER :: NPAR_GEOP=4,NPAR2_GEOP=2 INTEGER(I4B), PARAMETER :: NPAR_CUMSUM=16 INTEGER(I4B), PARAMETER :: NPAR_CUMPROD=8 INTEGER(I4B), PARAMETER :: NPAR_POLY=8 INTEGER(I4B), PARAMETER :: NPAR_POLYTERM=8 INTERFACE array_copy MODULE PROCEDURE array_copy_r, array_copy_d, array_copy_i END INTERFACE INTERFACE swap MODULE PROCEDURE swap_i,swap_r,swap_rv,swap_c, & swap_cv,swap_cm,swap_z,swap_zv,swap_zm, & masked_swap_rs,masked_swap_rv,masked_swap_rm END INTERFACE INTERFACE reallocate MODULE PROCEDURE reallocate_rv,reallocate_rm,& reallocate_iv,reallocate_im,reallocate_hv END INTERFACE INTERFACE imaxloc MODULE PROCEDURE imaxloc_r,imaxloc_i END INTERFACE INTERFACE assert MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v END INTERFACE INTERFACE assert_eq MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn END INTERFACE INTERFACE arth MODULE PROCEDURE arth_r, arth_d, arth_i END INTERFACE INTERFACE geop MODULE PROCEDURE geop_r, geop_d, geop_i, geop_c, geop_dv END INTERFACE INTERFACE cumsum MODULE PROCEDURE cumsum_r,cumsum_i END INTERFACE INTERFACE poly MODULE PROCEDURE poly_rr,poly_rrv,poly_dd,poly_ddv,& poly_rc,poly_cc,poly_msk_rrv,poly_msk_ddv END INTERFACE INTERFACE poly_term MODULE PROCEDURE poly_term_rr,poly_term_cc END INTERFACE INTERFACE outerprod MODULE PROCEDURE outerprod_r,outerprod_d END INTERFACE INTERFACE outerdiff MODULE PROCEDURE outerdiff_r,outerdiff_d,outerdiff_i END INTERFACE INTERFACE scatter_add MODULE PROCEDURE scatter_add_r,scatter_add_d END INTERFACE INTERFACE scatter_max MODULE PROCEDURE scatter_max_r,scatter_max_d END INTERFACE INTERFACE diagadd MODULE PROCEDURE diagadd_rv,diagadd_r END INTERFACE INTERFACE diagmult MODULE PROCEDURE diagmult_rv,diagmult_r END INTERFACE INTERFACE get_diag MODULE PROCEDURE get_diag_rv, get_diag_dv END INTERFACE INTERFACE put_diag MODULE PROCEDURE put_diag_rv, put_diag_r END INTERFACE CONTAINS !BL SUBROUTINE array_copy_r(src,dest,n_copied,n_not_copied) REAL(SP), DIMENSION(:), INTENT(IN) :: src REAL(SP), DIMENSION(:), INTENT(OUT) :: dest INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied n_copied=min(size(src),size(dest)) n_not_copied=size(src)-n_copied dest(1:n_copied)=src(1:n_copied) END SUBROUTINE array_copy_r !BL SUBROUTINE array_copy_d(src,dest,n_copied,n_not_copied) REAL(DP), DIMENSION(:), INTENT(IN) :: src REAL(DP), DIMENSION(:), INTENT(OUT) :: dest INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied n_copied=min(size(src),size(dest)) n_not_copied=size(src)-n_copied dest(1:n_copied)=src(1:n_copied) END SUBROUTINE array_copy_d !BL SUBROUTINE array_copy_i(src,dest,n_copied,n_not_copied) INTEGER(I4B), DIMENSION(:), INTENT(IN) :: src INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: dest INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied n_copied=min(size(src),size(dest)) n_not_copied=size(src)-n_copied dest(1:n_copied)=src(1:n_copied) END SUBROUTINE array_copy_i !BL !BL SUBROUTINE swap_i(a,b) INTEGER(I4B), INTENT(INOUT) :: a,b INTEGER(I4B) :: dum dum=a a=b b=dum END SUBROUTINE swap_i !BL SUBROUTINE swap_r(a,b) REAL(SP), INTENT(INOUT) :: a,b REAL(SP) :: dum dum=a a=b b=dum END SUBROUTINE swap_r !BL SUBROUTINE swap_rv(a,b) REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b REAL(SP), DIMENSION(SIZE(a)) :: dum dum=a a=b b=dum END SUBROUTINE swap_rv !BL SUBROUTINE swap_c(a,b) COMPLEX(SPC), INTENT(INOUT) :: a,b COMPLEX(SPC) :: dum dum=a a=b b=dum END SUBROUTINE swap_c !BL SUBROUTINE swap_cv(a,b) COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: a,b COMPLEX(SPC), DIMENSION(SIZE(a)) :: dum dum=a a=b b=dum END SUBROUTINE swap_cv !BL SUBROUTINE swap_cm(a,b) COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: a,b COMPLEX(SPC), DIMENSION(size(a,1),size(a,2)) :: dum dum=a a=b b=dum END SUBROUTINE swap_cm !BL SUBROUTINE swap_z(a,b) COMPLEX(DPC), INTENT(INOUT) :: a,b COMPLEX(DPC) :: dum dum=a a=b b=dum END SUBROUTINE swap_z !BL SUBROUTINE swap_zv(a,b) COMPLEX(DPC), DIMENSION(:), INTENT(INOUT) :: a,b COMPLEX(DPC), DIMENSION(SIZE(a)) :: dum dum=a a=b b=dum END SUBROUTINE swap_zv !BL SUBROUTINE swap_zm(a,b) COMPLEX(DPC), DIMENSION(:,:), INTENT(INOUT) :: a,b COMPLEX(DPC), DIMENSION(size(a,1),size(a,2)) :: dum dum=a a=b b=dum END SUBROUTINE swap_zm !BL SUBROUTINE masked_swap_rs(a,b,mask) REAL(SP), INTENT(INOUT) :: a,b LOGICAL(LGT), INTENT(IN) :: mask REAL(SP) :: swp if (mask) then swp=a a=b b=swp end if END SUBROUTINE masked_swap_rs !BL SUBROUTINE masked_swap_rv(a,b,mask) REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask REAL(SP), DIMENSION(size(a)) :: swp where (mask) swp=a a=b b=swp end where END SUBROUTINE masked_swap_rv !BL SUBROUTINE masked_swap_rm(a,b,mask) REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b LOGICAL(LGT), DIMENSION(:,:), INTENT(IN) :: mask REAL(SP), DIMENSION(size(a,1),size(a,2)) :: swp where (mask) swp=a a=b b=swp end where END SUBROUTINE masked_swap_rm !BL !BL FUNCTION reallocate_rv(p,n) REAL(SP), DIMENSION(:), POINTER :: p, reallocate_rv INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B) :: nold,ierr allocate(reallocate_rv(n),stat=ierr) if (ierr /= 0) call & nrerror('reallocate_rv: problem in attempt to allocate memory') if (.not. associated(p)) RETURN nold=size(p) reallocate_rv(1:min(nold,n))=p(1:min(nold,n)) deallocate(p) END FUNCTION reallocate_rv !BL FUNCTION reallocate_iv(p,n) INTEGER(I4B), DIMENSION(:), POINTER :: p, reallocate_iv INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B) :: nold,ierr allocate(reallocate_iv(n),stat=ierr) if (ierr /= 0) call & nrerror('reallocate_iv: problem in attempt to allocate memory') if (.not. associated(p)) RETURN nold=size(p) reallocate_iv(1:min(nold,n))=p(1:min(nold,n)) deallocate(p) END FUNCTION reallocate_iv !BL FUNCTION reallocate_hv(p,n) CHARACTER(1), DIMENSION(:), POINTER :: p, reallocate_hv INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B) :: nold,ierr allocate(reallocate_hv(n),stat=ierr) if (ierr /= 0) call & nrerror('reallocate_hv: problem in attempt to allocate memory') if (.not. associated(p)) RETURN nold=size(p) reallocate_hv(1:min(nold,n))=p(1:min(nold,n)) deallocate(p) END FUNCTION reallocate_hv !BL FUNCTION reallocate_rm(p,n,m) REAL(SP), DIMENSION(:,:), POINTER :: p, reallocate_rm INTEGER(I4B), INTENT(IN) :: n,m INTEGER(I4B) :: nold,mold,ierr allocate(reallocate_rm(n,m),stat=ierr) if (ierr /= 0) call & nrerror('reallocate_rm: problem in attempt to allocate memory') if (.not. associated(p)) RETURN nold=size(p,1) mold=size(p,2) reallocate_rm(1:min(nold,n),1:min(mold,m))=& p(1:min(nold,n),1:min(mold,m)) deallocate(p) END FUNCTION reallocate_rm !BL FUNCTION reallocate_im(p,n,m) INTEGER(I4B), DIMENSION(:,:), POINTER :: p, reallocate_im INTEGER(I4B), INTENT(IN) :: n,m INTEGER(I4B) :: nold,mold,ierr allocate(reallocate_im(n,m),stat=ierr) if (ierr /= 0) call & nrerror('reallocate_im: problem in attempt to allocate memory') if (.not. associated(p)) RETURN nold=size(p,1) mold=size(p,2) reallocate_im(1:min(nold,n),1:min(mold,m))=& p(1:min(nold,n),1:min(mold,m)) deallocate(p) END FUNCTION reallocate_im !BL FUNCTION ifirstloc(mask) LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask INTEGER(I4B) :: ifirstloc INTEGER(I4B), DIMENSION(1) :: loc loc=maxloc(merge(1,0,mask)) ifirstloc=loc(1) if (.not. mask(ifirstloc)) ifirstloc=size(mask)+1 END FUNCTION ifirstloc !BL FUNCTION imaxloc_r(arr) REAL(SP), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B) :: imaxloc_r INTEGER(I4B), DIMENSION(1) :: imax imax=maxloc(arr(:)) imaxloc_r=imax(1) END FUNCTION imaxloc_r !BL FUNCTION imaxloc_i(iarr) INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr INTEGER(I4B), DIMENSION(1) :: imax INTEGER(I4B) :: imaxloc_i imax=maxloc(iarr(:)) imaxloc_i=imax(1) END FUNCTION imaxloc_i !BL FUNCTION iminloc(arr) REAL(SP), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B), DIMENSION(1) :: imin INTEGER(I4B) :: iminloc imin=minloc(arr(:)) iminloc=imin(1) END FUNCTION iminloc !BL SUBROUTINE assert1(n1,string) CHARACTER(LEN=*), INTENT(IN) :: string LOGICAL, INTENT(IN) :: n1 if (.not. n1) then write (*,*) 'nrerror: an assertion failed with this tag:', & string STOP 'program terminated by assert1' end if END SUBROUTINE assert1 !BL SUBROUTINE assert2(n1,n2,string) CHARACTER(LEN=*), INTENT(IN) :: string LOGICAL, INTENT(IN) :: n1,n2 if (.not. (n1 .and. n2)) then write (*,*) 'nrerror: an assertion failed with this tag:', & string STOP 'program terminated by assert2' end if END SUBROUTINE assert2 !BL SUBROUTINE assert3(n1,n2,n3,string) CHARACTER(LEN=*), INTENT(IN) :: string LOGICAL, INTENT(IN) :: n1,n2,n3 if (.not. (n1 .and. n2 .and. n3)) then write (*,*) 'nrerror: an assertion failed with this tag:', & string STOP 'program terminated by assert3' end if END SUBROUTINE assert3 !BL SUBROUTINE assert4(n1,n2,n3,n4,string) CHARACTER(LEN=*), INTENT(IN) :: string LOGICAL, INTENT(IN) :: n1,n2,n3,n4 if (.not. (n1 .and. n2 .and. n3 .and. n4)) then write (*,*) 'nrerror: an assertion failed with this tag:', & string STOP 'program terminated by assert4' end if END SUBROUTINE assert4 !BL SUBROUTINE assert_v(n,string) CHARACTER(LEN=*), INTENT(IN) :: string LOGICAL, DIMENSION(:), INTENT(IN) :: n if (.not. all(n)) then write (*,*) 'nrerror: an assertion failed with this tag:', & string STOP 'program terminated by assert_v' end if END SUBROUTINE assert_v !BL FUNCTION assert_eq2(n1,n2,string) CHARACTER(LEN=*), INTENT(IN) :: string INTEGER, INTENT(IN) :: n1,n2 INTEGER :: assert_eq2 if (n1 == n2) then assert_eq2=n1 else write (*,*) 'nrerror: an assert_eq failed with this tag:', & string STOP 'program terminated by assert_eq2' end if END FUNCTION assert_eq2 !BL FUNCTION assert_eq3(n1,n2,n3,string) CHARACTER(LEN=*), INTENT(IN) :: string INTEGER, INTENT(IN) :: n1,n2,n3 INTEGER :: assert_eq3 if (n1 == n2 .and. n2 == n3) then assert_eq3=n1 else write (*,*) 'nrerror: an assert_eq failed with this tag:', & string STOP 'program terminated by assert_eq3' end if END FUNCTION assert_eq3 !BL FUNCTION assert_eq4(n1,n2,n3,n4,string) CHARACTER(LEN=*), INTENT(IN) :: string INTEGER, INTENT(IN) :: n1,n2,n3,n4 INTEGER :: assert_eq4 if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then assert_eq4=n1 else write (*,*) 'nrerror: an assert_eq failed with this tag:', & string STOP 'program terminated by assert_eq4' end if END FUNCTION assert_eq4 !BL FUNCTION assert_eqn(nn,string) CHARACTER(LEN=*), INTENT(IN) :: string INTEGER, DIMENSION(:), INTENT(IN) :: nn INTEGER :: assert_eqn if (all(nn(2:) == nn(1))) then assert_eqn=nn(1) else write (*,*) 'nrerror: an assert_eq failed with this tag:', & string STOP 'program terminated by assert_eqn' end if END FUNCTION assert_eqn !BL SUBROUTINE nrerror(string) CHARACTER(LEN=*), INTENT(IN) :: string write (*,*) 'nrerror: ',string STOP 'program terminated by nrerror' END SUBROUTINE nrerror !BL FUNCTION arth_r(first,increment,n) REAL(SP), INTENT(IN) :: first,increment INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(n) :: arth_r INTEGER(I4B) :: k,k2 REAL(SP) :: temp if (n > 0) arth_r(1)=first if (n <= NPAR_ARTH) then do k=2,n arth_r(k)=arth_r(k-1)+increment end do else do k=2,NPAR2_ARTH arth_r(k)=arth_r(k-1)+increment end do temp=increment*NPAR2_ARTH k=NPAR2_ARTH do if (k >= n) exit k2=k+k arth_r(k+1:min(k2,n))=temp+arth_r(1:min(k,n-k)) temp=temp+temp k=k2 end do end if END FUNCTION arth_r !BL FUNCTION arth_d(first,increment,n) REAL(DP), INTENT(IN) :: first,increment INTEGER(I4B), INTENT(IN) :: n REAL(DP), DIMENSION(n) :: arth_d INTEGER(I4B) :: k,k2 REAL(DP) :: temp if (n > 0) arth_d(1)=first if (n <= NPAR_ARTH) then do k=2,n arth_d(k)=arth_d(k-1)+increment end do else do k=2,NPAR2_ARTH arth_d(k)=arth_d(k-1)+increment end do temp=increment*NPAR2_ARTH k=NPAR2_ARTH do if (k >= n) exit k2=k+k arth_d(k+1:min(k2,n))=temp+arth_d(1:min(k,n-k)) temp=temp+temp k=k2 end do end if END FUNCTION arth_d !BL FUNCTION arth_i(first,increment,n) INTEGER(I4B), INTENT(IN) :: first,increment,n INTEGER(I4B), DIMENSION(n) :: arth_i INTEGER(I4B) :: k,k2,temp if (n > 0) arth_i(1)=first if (n <= NPAR_ARTH) then do k=2,n arth_i(k)=arth_i(k-1)+increment end do else do k=2,NPAR2_ARTH arth_i(k)=arth_i(k-1)+increment end do temp=increment*NPAR2_ARTH k=NPAR2_ARTH do if (k >= n) exit k2=k+k arth_i(k+1:min(k2,n))=temp+arth_i(1:min(k,n-k)) temp=temp+temp k=k2 end do end if END FUNCTION arth_i !BL !BL FUNCTION geop_r(first,factor,n) REAL(SP), INTENT(IN) :: first,factor INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(n) :: geop_r INTEGER(I4B) :: k,k2 REAL(SP) :: temp if (n > 0) geop_r(1)=first if (n <= NPAR_GEOP) then do k=2,n geop_r(k)=geop_r(k-1)*factor end do else do k=2,NPAR2_GEOP geop_r(k)=geop_r(k-1)*factor end do temp=factor**NPAR2_GEOP k=NPAR2_GEOP do if (k >= n) exit k2=k+k geop_r(k+1:min(k2,n))=temp*geop_r(1:min(k,n-k)) temp=temp*temp k=k2 end do end if END FUNCTION geop_r !BL FUNCTION geop_d(first,factor,n) REAL(DP), INTENT(IN) :: first,factor INTEGER(I4B), INTENT(IN) :: n REAL(DP), DIMENSION(n) :: geop_d INTEGER(I4B) :: k,k2 REAL(DP) :: temp if (n > 0) geop_d(1)=first if (n <= NPAR_GEOP) then do k=2,n geop_d(k)=geop_d(k-1)*factor end do else do k=2,NPAR2_GEOP geop_d(k)=geop_d(k-1)*factor end do temp=factor**NPAR2_GEOP k=NPAR2_GEOP do if (k >= n) exit k2=k+k geop_d(k+1:min(k2,n))=temp*geop_d(1:min(k,n-k)) temp=temp*temp k=k2 end do end if END FUNCTION geop_d !BL FUNCTION geop_i(first,factor,n) INTEGER(I4B), INTENT(IN) :: first,factor,n INTEGER(I4B), DIMENSION(n) :: geop_i INTEGER(I4B) :: k,k2,temp if (n > 0) geop_i(1)=first if (n <= NPAR_GEOP) then do k=2,n geop_i(k)=geop_i(k-1)*factor end do else do k=2,NPAR2_GEOP geop_i(k)=geop_i(k-1)*factor end do temp=factor**NPAR2_GEOP k=NPAR2_GEOP do if (k >= n) exit k2=k+k geop_i(k+1:min(k2,n))=temp*geop_i(1:min(k,n-k)) temp=temp*temp k=k2 end do end if END FUNCTION geop_i !BL FUNCTION geop_c(first,factor,n) COMPLEX(SP), INTENT(IN) :: first,factor INTEGER(I4B), INTENT(IN) :: n COMPLEX(SP), DIMENSION(n) :: geop_c INTEGER(I4B) :: k,k2 COMPLEX(SP) :: temp if (n > 0) geop_c(1)=first if (n <= NPAR_GEOP) then do k=2,n geop_c(k)=geop_c(k-1)*factor end do else do k=2,NPAR2_GEOP geop_c(k)=geop_c(k-1)*factor end do temp=factor**NPAR2_GEOP k=NPAR2_GEOP do if (k >= n) exit k2=k+k geop_c(k+1:min(k2,n))=temp*geop_c(1:min(k,n-k)) temp=temp*temp k=k2 end do end if END FUNCTION geop_c !BL FUNCTION geop_dv(first,factor,n) REAL(DP), DIMENSION(:), INTENT(IN) :: first,factor INTEGER(I4B), INTENT(IN) :: n REAL(DP), DIMENSION(size(first),n) :: geop_dv INTEGER(I4B) :: k,k2 REAL(DP), DIMENSION(size(first)) :: temp if (n > 0) geop_dv(:,1)=first(:) if (n <= NPAR_GEOP) then do k=2,n geop_dv(:,k)=geop_dv(:,k-1)*factor(:) end do else do k=2,NPAR2_GEOP geop_dv(:,k)=geop_dv(:,k-1)*factor(:) end do temp=factor**NPAR2_GEOP k=NPAR2_GEOP do if (k >= n) exit k2=k+k geop_dv(:,k+1:min(k2,n))=geop_dv(:,1:min(k,n-k))*& spread(temp,2,size(geop_dv(:,1:min(k,n-k)),2)) temp=temp*temp k=k2 end do end if END FUNCTION geop_dv !BL !BL RECURSIVE FUNCTION cumsum_r(arr,seed) RESULT(ans) REAL(SP), DIMENSION(:), INTENT(IN) :: arr REAL(SP), OPTIONAL, INTENT(IN) :: seed REAL(SP), DIMENSION(size(arr)) :: ans INTEGER(I4B) :: n,j REAL(SP) :: sd n=size(arr) if (n == 0_i4b) RETURN sd=0.0_sp if (present(seed)) sd=seed ans(1)=arr(1)+sd if (n < NPAR_CUMSUM) then do j=2,n ans(j)=ans(j-1)+arr(j) end do else ans(2:n:2)=cumsum_r(arr(2:n:2)+arr(1:n-1:2),sd) ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2) end if END FUNCTION cumsum_r !BL RECURSIVE FUNCTION cumsum_i(arr,seed) RESULT(ans) INTEGER(I4B), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed INTEGER(I4B), DIMENSION(size(arr)) :: ans INTEGER(I4B) :: n,j,sd n=size(arr) if (n == 0_i4b) RETURN sd=0_i4b if (present(seed)) sd=seed ans(1)=arr(1)+sd if (n < NPAR_CUMSUM) then do j=2,n ans(j)=ans(j-1)+arr(j) end do else ans(2:n:2)=cumsum_i(arr(2:n:2)+arr(1:n-1:2),sd) ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2) end if END FUNCTION cumsum_i !BL !BL RECURSIVE FUNCTION cumprod(arr,seed) RESULT(ans) REAL(SP), DIMENSION(:), INTENT(IN) :: arr REAL(SP), OPTIONAL, INTENT(IN) :: seed REAL(SP), DIMENSION(size(arr)) :: ans INTEGER(I4B) :: n,j REAL(SP) :: sd n=size(arr) if (n == 0_i4b) RETURN sd=1.0_sp if (present(seed)) sd=seed ans(1)=arr(1)*sd if (n < NPAR_CUMPROD) then do j=2,n ans(j)=ans(j-1)*arr(j) end do else ans(2:n:2)=cumprod(arr(2:n:2)*arr(1:n-1:2),sd) ans(3:n:2)=ans(2:n-1:2)*arr(3:n:2) end if END FUNCTION cumprod !BL !BL FUNCTION poly_rr(x,coeffs) REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs REAL(SP) :: poly_rr REAL(SP) :: pow REAL(SP), DIMENSION(:), ALLOCATABLE :: vec INTEGER(I4B) :: i,n,nn n=size(coeffs) if (n <= 0) then poly_rr=0.0_sp else if (n < NPAR_POLY) then poly_rr=coeffs(n) do i=n-1,1,-1 poly_rr=x*poly_rr+coeffs(i) end do else allocate(vec(n+1)) pow=x vec(1:n)=coeffs do vec(n+1)=0.0_sp nn=ishft(n+1,-1) vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) if (nn == 1) exit pow=pow*pow n=nn end do poly_rr=vec(1) deallocate(vec) end if END FUNCTION poly_rr !BL FUNCTION poly_dd(x,coeffs) REAL(DP), INTENT(IN) :: x REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs REAL(DP) :: poly_dd REAL(DP) :: pow REAL(DP), DIMENSION(:), ALLOCATABLE :: vec INTEGER(I4B) :: i,n,nn n=size(coeffs) if (n <= 0) then poly_dd=0.0_dp else if (n < NPAR_POLY) then poly_dd=coeffs(n) do i=n-1,1,-1 poly_dd=x*poly_dd+coeffs(i) end do else allocate(vec(n+1)) pow=x vec(1:n)=coeffs do vec(n+1)=0.0_dp nn=ishft(n+1,-1) vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) if (nn == 1) exit pow=pow*pow n=nn end do poly_dd=vec(1) deallocate(vec) end if END FUNCTION poly_dd !BL FUNCTION poly_rc(x,coeffs) COMPLEX(SPC), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs COMPLEX(SPC) :: poly_rc COMPLEX(SPC) :: pow COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec INTEGER(I4B) :: i,n,nn n=size(coeffs) if (n <= 0) then poly_rc=0.0_sp else if (n < NPAR_POLY) then poly_rc=coeffs(n) do i=n-1,1,-1 poly_rc=x*poly_rc+coeffs(i) end do else allocate(vec(n+1)) pow=x vec(1:n)=coeffs do vec(n+1)=0.0_sp nn=ishft(n+1,-1) vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) if (nn == 1) exit pow=pow*pow n=nn end do poly_rc=vec(1) deallocate(vec) end if END FUNCTION poly_rc !BL FUNCTION poly_cc(x,coeffs) COMPLEX(SPC), INTENT(IN) :: x COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: coeffs COMPLEX(SPC) :: poly_cc COMPLEX(SPC) :: pow COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec INTEGER(I4B) :: i,n,nn n=size(coeffs) if (n <= 0) then poly_cc=0.0_sp else if (n < NPAR_POLY) then poly_cc=coeffs(n) do i=n-1,1,-1 poly_cc=x*poly_cc+coeffs(i) end do else allocate(vec(n+1)) pow=x vec(1:n)=coeffs do vec(n+1)=0.0_sp nn=ishft(n+1,-1) vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) if (nn == 1) exit pow=pow*pow n=nn end do poly_cc=vec(1) deallocate(vec) end if END FUNCTION poly_cc !BL FUNCTION poly_rrv(x,coeffs) REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x REAL(SP), DIMENSION(size(x)) :: poly_rrv INTEGER(I4B) :: i,n,m m=size(coeffs) n=size(x) if (m <= 0) then poly_rrv=0.0_sp else if (m < n .or. m < NPAR_POLY) then poly_rrv=coeffs(m) do i=m-1,1,-1 poly_rrv=x*poly_rrv+coeffs(i) end do else do i=1,n poly_rrv(i)=poly_rr(x(i),coeffs) end do end if END FUNCTION poly_rrv !BL FUNCTION poly_ddv(x,coeffs) REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x REAL(DP), DIMENSION(size(x)) :: poly_ddv INTEGER(I4B) :: i,n,m m=size(coeffs) n=size(x) if (m <= 0) then poly_ddv=0.0_dp else if (m < n .or. m < NPAR_POLY) then poly_ddv=coeffs(m) do i=m-1,1,-1 poly_ddv=x*poly_ddv+coeffs(i) end do else do i=1,n poly_ddv(i)=poly_dd(x(i),coeffs) end do end if END FUNCTION poly_ddv !BL FUNCTION poly_msk_rrv(x,coeffs,mask) REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask REAL(SP), DIMENSION(size(x)) :: poly_msk_rrv poly_msk_rrv=unpack(poly_rrv(pack(x,mask),coeffs),mask,0.0_sp) END FUNCTION poly_msk_rrv !BL FUNCTION poly_msk_ddv(x,coeffs,mask) REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask REAL(DP), DIMENSION(size(x)) :: poly_msk_ddv poly_msk_ddv=unpack(poly_ddv(pack(x,mask),coeffs),mask,0.0_dp) END FUNCTION poly_msk_ddv !BL !BL RECURSIVE FUNCTION poly_term_rr(a,b) RESULT(u) REAL(SP), DIMENSION(:), INTENT(IN) :: a REAL(SP), INTENT(IN) :: b REAL(SP), DIMENSION(size(a)) :: u INTEGER(I4B) :: n,j n=size(a) if (n <= 0) RETURN u(1)=a(1) if (n < NPAR_POLYTERM) then do j=2,n u(j)=a(j)+b*u(j-1) end do else u(2:n:2)=poly_term_rr(a(2:n:2)+a(1:n-1:2)*b,b*b) u(3:n:2)=a(3:n:2)+b*u(2:n-1:2) end if END FUNCTION poly_term_rr !BL RECURSIVE FUNCTION poly_term_cc(a,b) RESULT(u) COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a COMPLEX(SPC), INTENT(IN) :: b COMPLEX(SPC), DIMENSION(size(a)) :: u INTEGER(I4B) :: n,j n=size(a) if (n <= 0) RETURN u(1)=a(1) if (n < NPAR_POLYTERM) then do j=2,n u(j)=a(j)+b*u(j-1) end do else u(2:n:2)=poly_term_cc(a(2:n:2)+a(1:n-1:2)*b,b*b) u(3:n:2)=a(3:n:2)+b*u(2:n-1:2) end if END FUNCTION poly_term_cc !BL !BL FUNCTION zroots_unity(n,nn) INTEGER(I4B), INTENT(IN) :: n,nn COMPLEX(SPC), DIMENSION(nn) :: zroots_unity INTEGER(I4B) :: k REAL(SP) :: theta zroots_unity(1)=1.0 theta=TWOPI/n k=1 do if (k >= nn) exit zroots_unity(k+1)=cmplx(cos(k*theta),sin(k*theta),SPC) zroots_unity(k+2:min(2*k,nn))=zroots_unity(k+1)*& zroots_unity(2:min(k,nn-k)) k=2*k end do END FUNCTION zroots_unity !BL FUNCTION outerprod_r(a,b) REAL(SP), DIMENSION(:), INTENT(IN) :: a,b REAL(SP), DIMENSION(size(a),size(b)) :: outerprod_r outerprod_r = spread(a,dim=2,ncopies=size(b)) * & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerprod_r !BL FUNCTION outerprod_d(a,b) REAL(DP), DIMENSION(:), INTENT(IN) :: a,b REAL(DP), DIMENSION(size(a),size(b)) :: outerprod_d outerprod_d = spread(a,dim=2,ncopies=size(b)) * & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerprod_d !BL FUNCTION outerdiv(a,b) REAL(SP), DIMENSION(:), INTENT(IN) :: a,b REAL(SP), DIMENSION(size(a),size(b)) :: outerdiv outerdiv = spread(a,dim=2,ncopies=size(b)) / & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerdiv !BL FUNCTION outersum(a,b) REAL(SP), DIMENSION(:), INTENT(IN) :: a,b REAL(SP), DIMENSION(size(a),size(b)) :: outersum outersum = spread(a,dim=2,ncopies=size(b)) + & spread(b,dim=1,ncopies=size(a)) END FUNCTION outersum !BL FUNCTION outerdiff_r(a,b) REAL(SP), DIMENSION(:), INTENT(IN) :: a,b REAL(SP), DIMENSION(size(a),size(b)) :: outerdiff_r outerdiff_r = spread(a,dim=2,ncopies=size(b)) - & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerdiff_r !BL FUNCTION outerdiff_d(a,b) REAL(DP), DIMENSION(:), INTENT(IN) :: a,b REAL(DP), DIMENSION(size(a),size(b)) :: outerdiff_d outerdiff_d = spread(a,dim=2,ncopies=size(b)) - & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerdiff_d !BL FUNCTION outerdiff_i(a,b) INTEGER(I4B), DIMENSION(:), INTENT(IN) :: a,b INTEGER(I4B), DIMENSION(size(a),size(b)) :: outerdiff_i outerdiff_i = spread(a,dim=2,ncopies=size(b)) - & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerdiff_i !BL FUNCTION outerand(a,b) LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: a,b LOGICAL(LGT), DIMENSION(size(a),size(b)) :: outerand outerand = spread(a,dim=2,ncopies=size(b)) .and. & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerand !BL SUBROUTINE scatter_add_r(dest,source,dest_index) REAL(SP), DIMENSION(:), INTENT(OUT) :: dest REAL(SP), DIMENSION(:), INTENT(IN) :: source INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index INTEGER(I4B) :: m,n,j,i n=assert_eq2(size(source),size(dest_index),'scatter_add_r') m=size(dest) do j=1,n i=dest_index(j) if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j) end do END SUBROUTINE scatter_add_r SUBROUTINE scatter_add_d(dest,source,dest_index) REAL(DP), DIMENSION(:), INTENT(OUT) :: dest REAL(DP), DIMENSION(:), INTENT(IN) :: source INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index INTEGER(I4B) :: m,n,j,i n=assert_eq2(size(source),size(dest_index),'scatter_add_d') m=size(dest) do j=1,n i=dest_index(j) if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j) end do END SUBROUTINE scatter_add_d SUBROUTINE scatter_max_r(dest,source,dest_index) REAL(SP), DIMENSION(:), INTENT(OUT) :: dest REAL(SP), DIMENSION(:), INTENT(IN) :: source INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index INTEGER(I4B) :: m,n,j,i n=assert_eq2(size(source),size(dest_index),'scatter_max_r') m=size(dest) do j=1,n i=dest_index(j) if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j)) end do END SUBROUTINE scatter_max_r SUBROUTINE scatter_max_d(dest,source,dest_index) REAL(DP), DIMENSION(:), INTENT(OUT) :: dest REAL(DP), DIMENSION(:), INTENT(IN) :: source INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index INTEGER(I4B) :: m,n,j,i n=assert_eq2(size(source),size(dest_index),'scatter_max_d') m=size(dest) do j=1,n i=dest_index(j) if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j)) end do END SUBROUTINE scatter_max_d !BL SUBROUTINE diagadd_rv(mat,diag) REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat REAL(SP), DIMENSION(:), INTENT(IN) :: diag INTEGER(I4B) :: j,n n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagadd_rv') do j=1,n mat(j,j)=mat(j,j)+diag(j) end do END SUBROUTINE diagadd_rv !BL SUBROUTINE diagadd_r(mat,diag) REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat REAL(SP), INTENT(IN) :: diag INTEGER(I4B) :: j,n n = min(size(mat,1),size(mat,2)) do j=1,n mat(j,j)=mat(j,j)+diag end do END SUBROUTINE diagadd_r !BL SUBROUTINE diagmult_rv(mat,diag) REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat REAL(SP), DIMENSION(:), INTENT(IN) :: diag INTEGER(I4B) :: j,n n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagmult_rv') do j=1,n mat(j,j)=mat(j,j)*diag(j) end do END SUBROUTINE diagmult_rv !BL SUBROUTINE diagmult_r(mat,diag) REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat REAL(SP), INTENT(IN) :: diag INTEGER(I4B) :: j,n n = min(size(mat,1),size(mat,2)) do j=1,n mat(j,j)=mat(j,j)*diag end do END SUBROUTINE diagmult_r !BL FUNCTION get_diag_rv(mat) REAL(SP), DIMENSION(:,:), INTENT(IN) :: mat REAL(SP), DIMENSION(size(mat,1)) :: get_diag_rv INTEGER(I4B) :: j j=assert_eq2(size(mat,1),size(mat,2),'get_diag_rv') do j=1,size(mat,1) get_diag_rv(j)=mat(j,j) end do END FUNCTION get_diag_rv !BL FUNCTION get_diag_dv(mat) REAL(DP), DIMENSION(:,:), INTENT(IN) :: mat REAL(DP), DIMENSION(size(mat,1)) :: get_diag_dv INTEGER(I4B) :: j j=assert_eq2(size(mat,1),size(mat,2),'get_diag_dv') do j=1,size(mat,1) get_diag_dv(j)=mat(j,j) end do END FUNCTION get_diag_dv !BL SUBROUTINE put_diag_rv(diagv,mat) REAL(SP), DIMENSION(:), INTENT(IN) :: diagv REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat INTEGER(I4B) :: j,n n=assert_eq2(size(diagv),min(size(mat,1),size(mat,2)),'put_diag_rv') do j=1,n mat(j,j)=diagv(j) end do END SUBROUTINE put_diag_rv !BL SUBROUTINE put_diag_r(scal,mat) REAL(SP), INTENT(IN) :: scal REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat INTEGER(I4B) :: j,n n = min(size(mat,1),size(mat,2)) do j=1,n mat(j,j)=scal end do END SUBROUTINE put_diag_r !BL SUBROUTINE unit_matrix(mat) REAL(SP), DIMENSION(:,:), INTENT(OUT) :: mat INTEGER(I4B) :: i,n n=min(size(mat,1),size(mat,2)) mat(:,:)=0.0_sp do i=1,n mat(i,i)=1.0_sp end do END SUBROUTINE unit_matrix !BL FUNCTION upper_triangle(j,k,extra) INTEGER(I4B), INTENT(IN) :: j,k INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra LOGICAL(LGT), DIMENSION(j,k) :: upper_triangle INTEGER(I4B) :: n n=0 if (present(extra)) n=extra upper_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) < n) END FUNCTION upper_triangle !BL FUNCTION lower_triangle(j,k,extra) INTEGER(I4B), INTENT(IN) :: j,k INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra LOGICAL(LGT), DIMENSION(j,k) :: lower_triangle INTEGER(I4B) :: n n=0 if (present(extra)) n=extra lower_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) > -n) END FUNCTION lower_triangle !BL FUNCTION vabs(v) REAL(SP), DIMENSION(:), INTENT(IN) :: v REAL(SP) :: vabs vabs=sqrt(dot_product(v,v)) END FUNCTION vabs !BL END MODULE nrutil MODULE ode_path USE nrtype INTEGER(I4B) :: nok,nbad,kount LOGICAL(LGT), SAVE :: save_steps=.false. REAL(SP) :: dxsav REAL(SP), DIMENSION(:), POINTER :: xp REAL(SP), DIMENSION(:,:), POINTER :: yp END MODULE ode_path MODULE hypgeo_info USE nrtype COMPLEX(SPC) :: hypgeo_aa,hypgeo_bb,hypgeo_cc,hypgeo_dz,hypgeo_z0 END MODULE hypgeo_info MODULE nr INTERFACE SUBROUTINE airy(x,ai,bi,aip,bip) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: ai,bi,aip,bip END SUBROUTINE airy END INTERFACE INTERFACE SUBROUTINE amebsa(p,y,pb,yb,ftol,func,iter,temptr) USE nrtype INTEGER(I4B), INTENT(INOUT) :: iter REAL(SP), INTENT(INOUT) :: yb REAL(SP), INTENT(IN) :: ftol,temptr REAL(SP), DIMENSION(:), INTENT(INOUT) :: y,pb REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE amebsa END INTERFACE INTERFACE SUBROUTINE amoeba(p,y,ftol,func,iter) USE nrtype INTEGER(I4B), INTENT(OUT) :: iter REAL(SP), INTENT(IN) :: ftol REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE amoeba END INTERFACE INTERFACE SUBROUTINE anneal(x,y,iorder) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: iorder REAL(SP), DIMENSION(:), INTENT(IN) :: x,y END SUBROUTINE anneal END INTERFACE INTERFACE SUBROUTINE asolve(b,x,itrnsp) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: b REAL(DP), DIMENSION(:), INTENT(OUT) :: x INTEGER(I4B), INTENT(IN) :: itrnsp END SUBROUTINE asolve END INTERFACE INTERFACE SUBROUTINE atimes(x,r,itrnsp) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: x REAL(DP), DIMENSION(:), INTENT(OUT) :: r INTEGER(I4B), INTENT(IN) :: itrnsp END SUBROUTINE atimes END INTERFACE INTERFACE SUBROUTINE avevar(data,ave,var) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data REAL(SP), INTENT(OUT) :: ave,var END SUBROUTINE avevar END INTERFACE INTERFACE SUBROUTINE balanc(a) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a END SUBROUTINE balanc END INTERFACE INTERFACE SUBROUTINE banbks(a,m1,m2,al,indx,b) USE nrtype INTEGER(I4B), INTENT(IN) :: m1,m2 INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,al REAL(SP), DIMENSION(:), INTENT(INOUT) :: b END SUBROUTINE banbks END INTERFACE INTERFACE SUBROUTINE bandec(a,m1,m2,al,indx,d) USE nrtype INTEGER(I4B), INTENT(IN) :: m1,m2 INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx REAL(SP), INTENT(OUT) :: d REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:,:), INTENT(OUT) :: al END SUBROUTINE bandec END INTERFACE INTERFACE SUBROUTINE banmul(a,m1,m2,x,b) USE nrtype INTEGER(I4B), INTENT(IN) :: m1,m2 REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(OUT) :: b REAL(SP), DIMENSION(:,:), INTENT(IN) :: a END SUBROUTINE banmul END INTERFACE INTERFACE SUBROUTINE bcucof(y,y1,y2,y12,d1,d2,c) USE nrtype REAL(SP), INTENT(IN) :: d1,d2 REAL(SP), DIMENSION(4), INTENT(IN) :: y,y1,y2,y12 REAL(SP), DIMENSION(4,4), INTENT(OUT) :: c END SUBROUTINE bcucof END INTERFACE INTERFACE SUBROUTINE bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy,& ansy1,ansy2) USE nrtype REAL(SP), DIMENSION(4), INTENT(IN) :: y,y1,y2,y12 REAL(SP), INTENT(IN) :: x1l,x1u,x2l,x2u,x1,x2 REAL(SP), INTENT(OUT) :: ansy,ansy1,ansy2 END SUBROUTINE bcuint END INTERFACE INTERFACE beschb SUBROUTINE beschb_s(x,gam1,gam2,gampl,gammi) USE nrtype REAL(DP), INTENT(IN) :: x REAL(DP), INTENT(OUT) :: gam1,gam2,gampl,gammi END SUBROUTINE beschb_s !BL SUBROUTINE beschb_v(x,gam1,gam2,gampl,gammi) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: x REAL(DP), DIMENSION(:), INTENT(OUT) :: gam1,gam2,gampl,gammi END SUBROUTINE beschb_v END INTERFACE INTERFACE bessi FUNCTION bessi_s(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: x REAL(SP) :: bessi_s END FUNCTION bessi_s !BL FUNCTION bessi_v(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessi_v END FUNCTION bessi_v END INTERFACE INTERFACE bessi0 FUNCTION bessi0_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessi0_s END FUNCTION bessi0_s !BL FUNCTION bessi0_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessi0_v END FUNCTION bessi0_v END INTERFACE INTERFACE bessi1 FUNCTION bessi1_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessi1_s END FUNCTION bessi1_s !BL FUNCTION bessi1_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessi1_v END FUNCTION bessi1_v END INTERFACE INTERFACE SUBROUTINE bessik(x,xnu,ri,rk,rip,rkp) USE nrtype REAL(SP), INTENT(IN) :: x,xnu REAL(SP), INTENT(OUT) :: ri,rk,rip,rkp END SUBROUTINE bessik END INTERFACE INTERFACE bessj FUNCTION bessj_s(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: x REAL(SP) :: bessj_s END FUNCTION bessj_s !BL FUNCTION bessj_v(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessj_v END FUNCTION bessj_v END INTERFACE INTERFACE bessj0 FUNCTION bessj0_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessj0_s END FUNCTION bessj0_s !BL FUNCTION bessj0_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessj0_v END FUNCTION bessj0_v END INTERFACE INTERFACE bessj1 FUNCTION bessj1_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessj1_s END FUNCTION bessj1_s !BL FUNCTION bessj1_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessj1_v END FUNCTION bessj1_v END INTERFACE INTERFACE bessjy SUBROUTINE bessjy_s(x,xnu,rj,ry,rjp,ryp) USE nrtype REAL(SP), INTENT(IN) :: x,xnu REAL(SP), INTENT(OUT) :: rj,ry,rjp,ryp END SUBROUTINE bessjy_s !BL SUBROUTINE bessjy_v(x,xnu,rj,ry,rjp,ryp) USE nrtype REAL(SP), INTENT(IN) :: xnu REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(OUT) :: rj,rjp,ry,ryp END SUBROUTINE bessjy_v END INTERFACE INTERFACE bessk FUNCTION bessk_s(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: x REAL(SP) :: bessk_s END FUNCTION bessk_s !BL FUNCTION bessk_v(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessk_v END FUNCTION bessk_v END INTERFACE INTERFACE bessk0 FUNCTION bessk0_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessk0_s END FUNCTION bessk0_s !BL FUNCTION bessk0_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessk0_v END FUNCTION bessk0_v END INTERFACE INTERFACE bessk1 FUNCTION bessk1_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessk1_s END FUNCTION bessk1_s !BL FUNCTION bessk1_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessk1_v END FUNCTION bessk1_v END INTERFACE INTERFACE bessy FUNCTION bessy_s(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: x REAL(SP) :: bessy_s END FUNCTION bessy_s !BL FUNCTION bessy_v(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessy_v END FUNCTION bessy_v END INTERFACE INTERFACE bessy0 FUNCTION bessy0_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessy0_s END FUNCTION bessy0_s !BL FUNCTION bessy0_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessy0_v END FUNCTION bessy0_v END INTERFACE INTERFACE bessy1 FUNCTION bessy1_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessy1_s END FUNCTION bessy1_s !BL FUNCTION bessy1_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessy1_v END FUNCTION bessy1_v END INTERFACE INTERFACE beta FUNCTION beta_s(z,w) USE nrtype REAL(SP), INTENT(IN) :: z,w REAL(SP) :: beta_s END FUNCTION beta_s !BL FUNCTION beta_v(z,w) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: z,w REAL(SP), DIMENSION(size(z)) :: beta_v END FUNCTION beta_v END INTERFACE INTERFACE betacf FUNCTION betacf_s(a,b,x) USE nrtype REAL(SP), INTENT(IN) :: a,b,x REAL(SP) :: betacf_s END FUNCTION betacf_s !BL FUNCTION betacf_v(a,b,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,x REAL(SP), DIMENSION(size(x)) :: betacf_v END FUNCTION betacf_v END INTERFACE INTERFACE betai FUNCTION betai_s(a,b,x) USE nrtype REAL(SP), INTENT(IN) :: a,b,x REAL(SP) :: betai_s END FUNCTION betai_s !BL FUNCTION betai_v(a,b,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,x REAL(SP), DIMENSION(size(a)) :: betai_v END FUNCTION betai_v END INTERFACE INTERFACE bico FUNCTION bico_s(n,k) USE nrtype INTEGER(I4B), INTENT(IN) :: n,k REAL(SP) :: bico_s END FUNCTION bico_s !BL FUNCTION bico_v(n,k) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n,k REAL(SP), DIMENSION(size(n)) :: bico_v END FUNCTION bico_v END INTERFACE INTERFACE FUNCTION bnldev(pp,n) USE nrtype REAL(SP), INTENT(IN) :: pp INTEGER(I4B), INTENT(IN) :: n REAL(SP) :: bnldev END FUNCTION bnldev END INTERFACE INTERFACE FUNCTION brent(ax,bx,cx,func,tol,xmin) USE nrtype REAL(SP), INTENT(IN) :: ax,bx,cx,tol REAL(SP), INTENT(OUT) :: xmin REAL(SP) :: brent INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION brent END INTERFACE INTERFACE SUBROUTINE broydn(x,check) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: x LOGICAL(LGT), INTENT(OUT) :: check END SUBROUTINE broydn END INTERFACE INTERFACE SUBROUTINE bsstep(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE bsstep END INTERFACE INTERFACE SUBROUTINE caldat(julian,mm,id,iyyy) USE nrtype INTEGER(I4B), INTENT(IN) :: julian INTEGER(I4B), INTENT(OUT) :: mm,id,iyyy END SUBROUTINE caldat END INTERFACE INTERFACE FUNCTION chder(a,b,c) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), DIMENSION(:), INTENT(IN) :: c REAL(SP), DIMENSION(size(c)) :: chder END FUNCTION chder END INTERFACE INTERFACE chebev FUNCTION chebev_s(a,b,c,x) USE nrtype REAL(SP), INTENT(IN) :: a,b,x REAL(SP), DIMENSION(:), INTENT(IN) :: c REAL(SP) :: chebev_s END FUNCTION chebev_s !BL FUNCTION chebev_v(a,b,c,x) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), DIMENSION(:), INTENT(IN) :: c,x REAL(SP), DIMENSION(size(x)) :: chebev_v END FUNCTION chebev_v END INTERFACE INTERFACE FUNCTION chebft(a,b,n,func) USE nrtype REAL(SP), INTENT(IN) :: a,b INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(n) :: chebft INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END FUNCTION chebft END INTERFACE INTERFACE FUNCTION chebpc(c) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: c REAL(SP), DIMENSION(size(c)) :: chebpc END FUNCTION chebpc END INTERFACE INTERFACE FUNCTION chint(a,b,c) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), DIMENSION(:), INTENT(IN) :: c REAL(SP), DIMENSION(size(c)) :: chint END FUNCTION chint END INTERFACE INTERFACE SUBROUTINE choldc(a,p) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:), INTENT(OUT) :: p END SUBROUTINE choldc END INTERFACE INTERFACE SUBROUTINE cholsl(a,p,b,x) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: a REAL(SP), DIMENSION(:), INTENT(IN) :: p,b REAL(SP), DIMENSION(:), INTENT(INOUT) :: x END SUBROUTINE cholsl END INTERFACE INTERFACE SUBROUTINE chsone(bins,ebins,knstrn,df,chsq,prob) USE nrtype INTEGER(I4B), INTENT(IN) :: knstrn REAL(SP), INTENT(OUT) :: df,chsq,prob REAL(SP), DIMENSION(:), INTENT(IN) :: bins,ebins END SUBROUTINE chsone END INTERFACE INTERFACE SUBROUTINE chstwo(bins1,bins2,knstrn,df,chsq,prob) USE nrtype INTEGER(I4B), INTENT(IN) :: knstrn REAL(SP), INTENT(OUT) :: df,chsq,prob REAL(SP), DIMENSION(:), INTENT(IN) :: bins1,bins2 END SUBROUTINE chstwo END INTERFACE INTERFACE SUBROUTINE cisi(x,ci,si) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: ci,si END SUBROUTINE cisi END INTERFACE INTERFACE SUBROUTINE cntab1(nn,chisq,df,prob,cramrv,ccc) USE nrtype INTEGER(I4B), DIMENSION(:,:), INTENT(IN) :: nn REAL(SP), INTENT(OUT) :: chisq,df,prob,cramrv,ccc END SUBROUTINE cntab1 END INTERFACE INTERFACE SUBROUTINE cntab2(nn,h,hx,hy,hygx,hxgy,uygx,uxgy,uxy) USE nrtype INTEGER(I4B), DIMENSION(:,:), INTENT(IN) :: nn REAL(SP), INTENT(OUT) :: h,hx,hy,hygx,hxgy,uygx,uxgy,uxy END SUBROUTINE cntab2 END INTERFACE INTERFACE FUNCTION convlv(data,respns,isign) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data REAL(SP), DIMENSION(:), INTENT(IN) :: respns INTEGER(I4B), INTENT(IN) :: isign REAL(SP), DIMENSION(size(data)) :: convlv END FUNCTION convlv END INTERFACE INTERFACE FUNCTION correl(data1,data2) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 REAL(SP), DIMENSION(size(data1)) :: correl END FUNCTION correl END INTERFACE INTERFACE SUBROUTINE cosft1(y) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y END SUBROUTINE cosft1 END INTERFACE INTERFACE SUBROUTINE cosft2(y,isign) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE cosft2 END INTERFACE INTERFACE SUBROUTINE covsrt(covar,maska) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska END SUBROUTINE covsrt END INTERFACE INTERFACE SUBROUTINE cyclic(a,b,c,alpha,beta,r,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN):: a,b,c,r REAL(SP), INTENT(IN) :: alpha,beta REAL(SP), DIMENSION(:), INTENT(OUT):: x END SUBROUTINE cyclic END INTERFACE INTERFACE SUBROUTINE daub4(a,isign) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: a INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE daub4 END INTERFACE INTERFACE dawson FUNCTION dawson_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: dawson_s END FUNCTION dawson_s !BL FUNCTION dawson_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: dawson_v END FUNCTION dawson_v END INTERFACE INTERFACE FUNCTION dbrent(ax,bx,cx,func,dbrent_dfunc,tol,xmin) USE nrtype REAL(SP), INTENT(IN) :: ax,bx,cx,tol REAL(SP), INTENT(OUT) :: xmin REAL(SP) :: dbrent INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func !BL FUNCTION dbrent_dfunc(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: dbrent_dfunc END FUNCTION dbrent_dfunc END INTERFACE END FUNCTION dbrent END INTERFACE INTERFACE SUBROUTINE ddpoly(c,x,pd) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: c REAL(SP), DIMENSION(:), INTENT(OUT) :: pd END SUBROUTINE ddpoly END INTERFACE INTERFACE FUNCTION decchk(string,ch) USE nrtype CHARACTER(1), DIMENSION(:), INTENT(IN) :: string CHARACTER(1), INTENT(OUT) :: ch LOGICAL(LGT) :: decchk END FUNCTION decchk END INTERFACE INTERFACE SUBROUTINE dfpmin(p,gtol,iter,fret,func,dfunc) USE nrtype INTEGER(I4B), INTENT(OUT) :: iter REAL(SP), INTENT(IN) :: gtol REAL(SP), INTENT(OUT) :: fret REAL(SP), DIMENSION(:), INTENT(INOUT) :: p INTERFACE FUNCTION func(p) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: p REAL(SP) :: func END FUNCTION func !BL FUNCTION dfunc(p) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: p REAL(SP), DIMENSION(size(p)) :: dfunc END FUNCTION dfunc END INTERFACE END SUBROUTINE dfpmin END INTERFACE INTERFACE FUNCTION dfridr(func,x,h,err) USE nrtype REAL(SP), INTENT(IN) :: x,h REAL(SP), INTENT(OUT) :: err REAL(SP) :: dfridr INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION dfridr END INTERFACE INTERFACE SUBROUTINE dftcor(w,delta,a,b,endpts,corre,corim,corfac) USE nrtype REAL(SP), INTENT(IN) :: w,delta,a,b REAL(SP), INTENT(OUT) :: corre,corim,corfac REAL(SP), DIMENSION(:), INTENT(IN) :: endpts END SUBROUTINE dftcor END INTERFACE INTERFACE SUBROUTINE dftint(func,a,b,w,cosint,sinint) USE nrtype REAL(SP), INTENT(IN) :: a,b,w REAL(SP), INTENT(OUT) :: cosint,sinint INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END SUBROUTINE dftint END INTERFACE INTERFACE SUBROUTINE difeq(k,k1,k2,jsf,is1,isf,indexv,s,y) USE nrtype INTEGER(I4B), INTENT(IN) :: is1,isf,jsf,k,k1,k2 INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv REAL(SP), DIMENSION(:,:), INTENT(OUT) :: s REAL(SP), DIMENSION(:,:), INTENT(IN) :: y END SUBROUTINE difeq END INTERFACE INTERFACE FUNCTION eclass(lista,listb,n) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(IN) :: lista,listb INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B), DIMENSION(n) :: eclass END FUNCTION eclass END INTERFACE INTERFACE FUNCTION eclazz(equiv,n) USE nrtype INTERFACE FUNCTION equiv(i,j) USE nrtype LOGICAL(LGT) :: equiv INTEGER(I4B), INTENT(IN) :: i,j END FUNCTION equiv END INTERFACE INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B), DIMENSION(n) :: eclazz END FUNCTION eclazz END INTERFACE INTERFACE FUNCTION ei(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: ei END FUNCTION ei END INTERFACE INTERFACE SUBROUTINE eigsrt(d,v) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: d REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: v END SUBROUTINE eigsrt END INTERFACE INTERFACE elle FUNCTION elle_s(phi,ak) USE nrtype REAL(SP), INTENT(IN) :: phi,ak REAL(SP) :: elle_s END FUNCTION elle_s !BL FUNCTION elle_v(phi,ak) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak REAL(SP), DIMENSION(size(phi)) :: elle_v END FUNCTION elle_v END INTERFACE INTERFACE ellf FUNCTION ellf_s(phi,ak) USE nrtype REAL(SP), INTENT(IN) :: phi,ak REAL(SP) :: ellf_s END FUNCTION ellf_s !BL FUNCTION ellf_v(phi,ak) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak REAL(SP), DIMENSION(size(phi)) :: ellf_v END FUNCTION ellf_v END INTERFACE INTERFACE ellpi FUNCTION ellpi_s(phi,en,ak) USE nrtype REAL(SP), INTENT(IN) :: phi,en,ak REAL(SP) :: ellpi_s END FUNCTION ellpi_s !BL FUNCTION ellpi_v(phi,en,ak) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: phi,en,ak REAL(SP), DIMENSION(size(phi)) :: ellpi_v END FUNCTION ellpi_v END INTERFACE INTERFACE SUBROUTINE elmhes(a) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a END SUBROUTINE elmhes END INTERFACE INTERFACE erf FUNCTION erf_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: erf_s END FUNCTION erf_s !BL FUNCTION erf_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: erf_v END FUNCTION erf_v END INTERFACE INTERFACE erfc FUNCTION erfc_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: erfc_s END FUNCTION erfc_s !BL FUNCTION erfc_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: erfc_v END FUNCTION erfc_v END INTERFACE INTERFACE erfcc FUNCTION erfcc_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: erfcc_s END FUNCTION erfcc_s !BL FUNCTION erfcc_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: erfcc_v END FUNCTION erfcc_v END INTERFACE INTERFACE SUBROUTINE eulsum(sum,term,jterm) USE nrtype REAL(SP), INTENT(INOUT) :: sum REAL(SP), INTENT(IN) :: term INTEGER(I4B), INTENT(IN) :: jterm END SUBROUTINE eulsum END INTERFACE INTERFACE FUNCTION evlmem(fdt,d,xms) USE nrtype REAL(SP), INTENT(IN) :: fdt,xms REAL(SP), DIMENSION(:), INTENT(IN) :: d REAL(SP) :: evlmem END FUNCTION evlmem END INTERFACE INTERFACE expdev SUBROUTINE expdev_s(harvest) USE nrtype REAL(SP), INTENT(OUT) :: harvest END SUBROUTINE expdev_s !BL SUBROUTINE expdev_v(harvest) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest END SUBROUTINE expdev_v END INTERFACE INTERFACE FUNCTION expint(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: x REAL(SP) :: expint END FUNCTION expint END INTERFACE INTERFACE factln FUNCTION factln_s(n) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP) :: factln_s END FUNCTION factln_s !BL FUNCTION factln_v(n) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n REAL(SP), DIMENSION(size(n)) :: factln_v END FUNCTION factln_v END INTERFACE INTERFACE factrl FUNCTION factrl_s(n) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP) :: factrl_s END FUNCTION factrl_s !BL FUNCTION factrl_v(n) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n REAL(SP), DIMENSION(size(n)) :: factrl_v END FUNCTION factrl_v END INTERFACE INTERFACE SUBROUTINE fasper(x,y,ofac,hifac,px,py,jmax,prob) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), INTENT(IN) :: ofac,hifac INTEGER(I4B), INTENT(OUT) :: jmax REAL(SP), INTENT(OUT) :: prob REAL(SP), DIMENSION(:), POINTER :: px,py END SUBROUTINE fasper END INTERFACE INTERFACE SUBROUTINE fdjac(x,fvec,df) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: fvec REAL(SP), DIMENSION(:), INTENT(INOUT) :: x REAL(SP), DIMENSION(:,:), INTENT(OUT) :: df END SUBROUTINE fdjac END INTERFACE INTERFACE SUBROUTINE fgauss(x,a,y,dyda) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,a REAL(SP), DIMENSION(:), INTENT(OUT) :: y REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda END SUBROUTINE fgauss END INTERFACE INTERFACE SUBROUTINE fit(x,y,a,b,siga,sigb,chi2,q,sig) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q REAL(SP), DIMENSION(:), OPTIONAL, INTENT(IN) :: sig END SUBROUTINE fit END INTERFACE INTERFACE SUBROUTINE fitexy(x,y,sigx,sigy,a,b,siga,sigb,chi2,q) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sigx,sigy REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q END SUBROUTINE fitexy END INTERFACE INTERFACE SUBROUTINE fixrts(d) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: d END SUBROUTINE fixrts END INTERFACE INTERFACE FUNCTION fleg(x,n) USE nrtype REAL(SP), INTENT(IN) :: x INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(n) :: fleg END FUNCTION fleg END INTERFACE INTERFACE SUBROUTINE flmoon(n,nph,jd,frac) USE nrtype INTEGER(I4B), INTENT(IN) :: n,nph INTEGER(I4B), INTENT(OUT) :: jd REAL(SP), INTENT(OUT) :: frac END SUBROUTINE flmoon END INTERFACE INTERFACE four1 SUBROUTINE four1_dp(data,isign) USE nrtype COMPLEX(DPC), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE four1_dp !BL SUBROUTINE four1_sp(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE four1_sp END INTERFACE INTERFACE SUBROUTINE four1_alt(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE four1_alt END INTERFACE INTERFACE SUBROUTINE four1_gather(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE four1_gather END INTERFACE INTERFACE SUBROUTINE four2(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data INTEGER(I4B),INTENT(IN) :: isign END SUBROUTINE four2 END INTERFACE INTERFACE SUBROUTINE four2_alt(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE four2_alt END INTERFACE INTERFACE SUBROUTINE four3(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data INTEGER(I4B),INTENT(IN) :: isign END SUBROUTINE four3 END INTERFACE INTERFACE SUBROUTINE four3_alt(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE four3_alt END INTERFACE INTERFACE SUBROUTINE fourcol(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE fourcol END INTERFACE INTERFACE SUBROUTINE fourcol_3d(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE fourcol_3d END INTERFACE INTERFACE SUBROUTINE fourn_gather(data,nn,isign) USE nrtype COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE fourn_gather END INTERFACE INTERFACE fourrow SUBROUTINE fourrow_dp(data,isign) USE nrtype COMPLEX(DPC), DIMENSION(:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE fourrow_dp !BL SUBROUTINE fourrow_sp(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE fourrow_sp END INTERFACE INTERFACE SUBROUTINE fourrow_3d(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE fourrow_3d END INTERFACE INTERFACE FUNCTION fpoly(x,n) USE nrtype REAL(SP), INTENT(IN) :: x INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(n) :: fpoly END FUNCTION fpoly END INTERFACE INTERFACE SUBROUTINE fred2(a,b,t,f,w,g,ak) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), DIMENSION(:), INTENT(OUT) :: t,f,w INTERFACE FUNCTION g(t) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: t REAL(SP), DIMENSION(size(t)) :: g END FUNCTION g !BL FUNCTION ak(t,s) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: t,s REAL(SP), DIMENSION(size(t),size(s)) :: ak END FUNCTION ak END INTERFACE END SUBROUTINE fred2 END INTERFACE INTERFACE FUNCTION fredin(x,a,b,t,f,w,g,ak) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), DIMENSION(:), INTENT(IN) :: x,t,f,w REAL(SP), DIMENSION(size(x)) :: fredin INTERFACE FUNCTION g(t) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: t REAL(SP), DIMENSION(size(t)) :: g END FUNCTION g !BL FUNCTION ak(t,s) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: t,s REAL(SP), DIMENSION(size(t),size(s)) :: ak END FUNCTION ak END INTERFACE END FUNCTION fredin END INTERFACE INTERFACE SUBROUTINE frenel(x,s,c) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: s,c END SUBROUTINE frenel END INTERFACE INTERFACE SUBROUTINE frprmn(p,ftol,iter,fret) USE nrtype INTEGER(I4B), INTENT(OUT) :: iter REAL(SP), INTENT(IN) :: ftol REAL(SP), INTENT(OUT) :: fret REAL(SP), DIMENSION(:), INTENT(INOUT) :: p END SUBROUTINE frprmn END INTERFACE INTERFACE SUBROUTINE ftest(data1,data2,f,prob) USE nrtype REAL(SP), INTENT(OUT) :: f,prob REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 END SUBROUTINE ftest END INTERFACE INTERFACE FUNCTION gamdev(ia) USE nrtype INTEGER(I4B), INTENT(IN) :: ia REAL(SP) :: gamdev END FUNCTION gamdev END INTERFACE INTERFACE gammln FUNCTION gammln_s(xx) USE nrtype REAL(SP), INTENT(IN) :: xx REAL(SP) :: gammln_s END FUNCTION gammln_s !BL FUNCTION gammln_v(xx) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xx REAL(SP), DIMENSION(size(xx)) :: gammln_v END FUNCTION gammln_v END INTERFACE INTERFACE gammp FUNCTION gammp_s(a,x) USE nrtype REAL(SP), INTENT(IN) :: a,x REAL(SP) :: gammp_s END FUNCTION gammp_s !BL FUNCTION gammp_v(a,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,x REAL(SP), DIMENSION(size(a)) :: gammp_v END FUNCTION gammp_v END INTERFACE INTERFACE gammq FUNCTION gammq_s(a,x) USE nrtype REAL(SP), INTENT(IN) :: a,x REAL(SP) :: gammq_s END FUNCTION gammq_s !BL FUNCTION gammq_v(a,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,x REAL(SP), DIMENSION(size(a)) :: gammq_v END FUNCTION gammq_v END INTERFACE INTERFACE gasdev SUBROUTINE gasdev_s(harvest) USE nrtype REAL(SP), INTENT(OUT) :: harvest END SUBROUTINE gasdev_s !BL SUBROUTINE gasdev_v(harvest) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest END SUBROUTINE gasdev_v END INTERFACE INTERFACE SUBROUTINE gaucof(a,b,amu0,x,w) USE nrtype REAL(SP), INTENT(IN) :: amu0 REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w END SUBROUTINE gaucof END INTERFACE INTERFACE SUBROUTINE gauher(x,w) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w END SUBROUTINE gauher END INTERFACE INTERFACE SUBROUTINE gaujac(x,w,alf,bet) USE nrtype REAL(SP), INTENT(IN) :: alf,bet REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w END SUBROUTINE gaujac END INTERFACE INTERFACE SUBROUTINE gaulag(x,w,alf) USE nrtype REAL(SP), INTENT(IN) :: alf REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w END SUBROUTINE gaulag END INTERFACE INTERFACE SUBROUTINE gauleg(x1,x2,x,w) USE nrtype REAL(SP), INTENT(IN) :: x1,x2 REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w END SUBROUTINE gauleg END INTERFACE INTERFACE SUBROUTINE gaussj(a,b) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b END SUBROUTINE gaussj END INTERFACE INTERFACE gcf FUNCTION gcf_s(a,x,gln) USE nrtype REAL(SP), INTENT(IN) :: a,x REAL(SP), OPTIONAL, INTENT(OUT) :: gln REAL(SP) :: gcf_s END FUNCTION gcf_s !BL FUNCTION gcf_v(a,x,gln) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,x REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln REAL(SP), DIMENSION(size(a)) :: gcf_v END FUNCTION gcf_v END INTERFACE INTERFACE FUNCTION golden(ax,bx,cx,func,tol,xmin) USE nrtype REAL(SP), INTENT(IN) :: ax,bx,cx,tol REAL(SP), INTENT(OUT) :: xmin REAL(SP) :: golden INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION golden END INTERFACE INTERFACE gser FUNCTION gser_s(a,x,gln) USE nrtype REAL(SP), INTENT(IN) :: a,x REAL(SP), OPTIONAL, INTENT(OUT) :: gln REAL(SP) :: gser_s END FUNCTION gser_s !BL FUNCTION gser_v(a,x,gln) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,x REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln REAL(SP), DIMENSION(size(a)) :: gser_v END FUNCTION gser_v END INTERFACE INTERFACE SUBROUTINE hqr(a,wr,wi) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: wr,wi REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a END SUBROUTINE hqr END INTERFACE INTERFACE SUBROUTINE hunt(xx,x,jlo) USE nrtype INTEGER(I4B), INTENT(INOUT) :: jlo REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: xx END SUBROUTINE hunt END INTERFACE INTERFACE SUBROUTINE hypdrv(s,ry,rdyds) USE nrtype REAL(SP), INTENT(IN) :: s REAL(SP), DIMENSION(:), INTENT(IN) :: ry REAL(SP), DIMENSION(:), INTENT(OUT) :: rdyds END SUBROUTINE hypdrv END INTERFACE INTERFACE FUNCTION hypgeo(a,b,c,z) USE nrtype COMPLEX(SPC), INTENT(IN) :: a,b,c,z COMPLEX(SPC) :: hypgeo END FUNCTION hypgeo END INTERFACE INTERFACE SUBROUTINE hypser(a,b,c,z,series,deriv) USE nrtype COMPLEX(SPC), INTENT(IN) :: a,b,c,z COMPLEX(SPC), INTENT(OUT) :: series,deriv END SUBROUTINE hypser END INTERFACE INTERFACE FUNCTION icrc(crc,buf,jinit,jrev) USE nrtype CHARACTER(1), DIMENSION(:), INTENT(IN) :: buf INTEGER(I2B), INTENT(IN) :: crc,jinit INTEGER(I4B), INTENT(IN) :: jrev INTEGER(I2B) :: icrc END FUNCTION icrc END INTERFACE INTERFACE FUNCTION igray(n,is) USE nrtype INTEGER(I4B), INTENT(IN) :: n,is INTEGER(I4B) :: igray END FUNCTION igray END INTERFACE INTERFACE RECURSIVE SUBROUTINE index_bypack(arr,index,partial) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: index INTEGER, OPTIONAL, INTENT(IN) :: partial END SUBROUTINE index_bypack END INTERFACE INTERFACE indexx SUBROUTINE indexx_sp(arr,index) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index END SUBROUTINE indexx_sp SUBROUTINE indexx_i4b(iarr,index) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index END SUBROUTINE indexx_i4b END INTERFACE INTERFACE FUNCTION interp(uc) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: uc REAL(DP), DIMENSION(2*size(uc,1)-1,2*size(uc,1)-1) :: interp END FUNCTION interp END INTERFACE INTERFACE FUNCTION rank(indx) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx INTEGER(I4B), DIMENSION(size(indx)) :: rank END FUNCTION rank END INTERFACE INTERFACE FUNCTION irbit1(iseed) USE nrtype INTEGER(I4B), INTENT(INOUT) :: iseed INTEGER(I4B) :: irbit1 END FUNCTION irbit1 END INTERFACE INTERFACE FUNCTION irbit2(iseed) USE nrtype INTEGER(I4B), INTENT(INOUT) :: iseed INTEGER(I4B) :: irbit2 END FUNCTION irbit2 END INTERFACE INTERFACE SUBROUTINE jacobi(a,d,v,nrot) USE nrtype INTEGER(I4B), INTENT(OUT) :: nrot REAL(SP), DIMENSION(:), INTENT(OUT) :: d REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v END SUBROUTINE jacobi END INTERFACE INTERFACE SUBROUTINE jacobn(x,y,dfdx,dfdy) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dfdx REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dfdy END SUBROUTINE jacobn END INTERFACE INTERFACE FUNCTION julday(mm,id,iyyy) USE nrtype INTEGER(I4B), INTENT(IN) :: mm,id,iyyy INTEGER(I4B) :: julday END FUNCTION julday END INTERFACE INTERFACE SUBROUTINE kendl1(data1,data2,tau,z,prob) USE nrtype REAL(SP), INTENT(OUT) :: tau,z,prob REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 END SUBROUTINE kendl1 END INTERFACE INTERFACE SUBROUTINE kendl2(tab,tau,z,prob) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: tab REAL(SP), INTENT(OUT) :: tau,z,prob END SUBROUTINE kendl2 END INTERFACE INTERFACE FUNCTION kermom(y,m) USE nrtype REAL(DP), INTENT(IN) :: y INTEGER(I4B), INTENT(IN) :: m REAL(DP), DIMENSION(m) :: kermom END FUNCTION kermom END INTERFACE INTERFACE SUBROUTINE ks2d1s(x1,y1,quadvl,d1,prob) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x1,y1 REAL(SP), INTENT(OUT) :: d1,prob INTERFACE SUBROUTINE quadvl(x,y,fa,fb,fc,fd) USE nrtype REAL(SP), INTENT(IN) :: x,y REAL(SP), INTENT(OUT) :: fa,fb,fc,fd END SUBROUTINE quadvl END INTERFACE END SUBROUTINE ks2d1s END INTERFACE INTERFACE SUBROUTINE ks2d2s(x1,y1,x2,y2,d,prob) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x1,y1,x2,y2 REAL(SP), INTENT(OUT) :: d,prob END SUBROUTINE ks2d2s END INTERFACE INTERFACE SUBROUTINE ksone(data,func,d,prob) USE nrtype REAL(SP), INTENT(OUT) :: d,prob REAL(SP), DIMENSION(:), INTENT(INOUT) :: data INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END SUBROUTINE ksone END INTERFACE INTERFACE SUBROUTINE kstwo(data1,data2,d,prob) USE nrtype REAL(SP), INTENT(OUT) :: d,prob REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 END SUBROUTINE kstwo END INTERFACE INTERFACE SUBROUTINE laguer(a,x,its) USE nrtype INTEGER(I4B), INTENT(OUT) :: its COMPLEX(SPC), INTENT(INOUT) :: x COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a END SUBROUTINE laguer END INTERFACE INTERFACE SUBROUTINE lfit(x,y,sig,a,maska,covar,chisq,funcs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig REAL(SP), DIMENSION(:), INTENT(INOUT) :: a LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar REAL(SP), INTENT(OUT) :: chisq INTERFACE SUBROUTINE funcs(x,arr) USE nrtype REAL(SP),INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(OUT) :: arr END SUBROUTINE funcs END INTERFACE END SUBROUTINE lfit END INTERFACE INTERFACE SUBROUTINE linbcg(b,x,itol,tol,itmax,iter,err) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: b REAL(DP), DIMENSION(:), INTENT(INOUT) :: x INTEGER(I4B), INTENT(IN) :: itol,itmax REAL(DP), INTENT(IN) :: tol INTEGER(I4B), INTENT(OUT) :: iter REAL(DP), INTENT(OUT) :: err END SUBROUTINE linbcg END INTERFACE INTERFACE SUBROUTINE linmin(p,xi,fret) USE nrtype REAL(SP), INTENT(OUT) :: fret REAL(SP), DIMENSION(:), TARGET, INTENT(INOUT) :: p,xi END SUBROUTINE linmin END INTERFACE INTERFACE SUBROUTINE lnsrch(xold,fold,g,p,x,f,stpmax,check,func) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xold,g REAL(SP), DIMENSION(:), INTENT(INOUT) :: p REAL(SP), INTENT(IN) :: fold,stpmax REAL(SP), DIMENSION(:), INTENT(OUT) :: x REAL(SP), INTENT(OUT) :: f LOGICAL(LGT), INTENT(OUT) :: check INTERFACE FUNCTION func(x) USE nrtype REAL(SP) :: func REAL(SP), DIMENSION(:), INTENT(IN) :: x END FUNCTION func END INTERFACE END SUBROUTINE lnsrch END INTERFACE INTERFACE FUNCTION locatenr(xx,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xx REAL(SP), INTENT(IN) :: x INTEGER(I4B) :: locatenr END FUNCTION locatenr END INTERFACE INTERFACE FUNCTION lop(u) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: u REAL(DP), DIMENSION(size(u,1),size(u,1)) :: lop END FUNCTION lop END INTERFACE INTERFACE SUBROUTINE lubksb(a,indx,b) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: a INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx REAL(SP), DIMENSION(:), INTENT(INOUT) :: b END SUBROUTINE lubksb END INTERFACE INTERFACE SUBROUTINE ludcmp(a,indx,d) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx REAL(SP), INTENT(OUT) :: d END SUBROUTINE ludcmp END INTERFACE INTERFACE SUBROUTINE machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,& maxexp,eps,epsneg,xmin,xmax) USE nrtype INTEGER(I4B), INTENT(OUT) :: ibeta,iexp,irnd,it,machep,maxexp,& minexp,negep,ngrd REAL(SP), INTENT(OUT) :: eps,epsneg,xmax,xmin END SUBROUTINE machar END INTERFACE INTERFACE SUBROUTINE medfit(x,y,a,b,abdev) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), INTENT(OUT) :: a,b,abdev END SUBROUTINE medfit END INTERFACE INTERFACE SUBROUTINE memcof(data,xms,d) USE nrtype REAL(SP), INTENT(OUT) :: xms REAL(SP), DIMENSION(:), INTENT(IN) :: data REAL(SP), DIMENSION(:), INTENT(OUT) :: d END SUBROUTINE memcof END INTERFACE INTERFACE SUBROUTINE mgfas(u,maxcyc) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u INTEGER(I4B), INTENT(IN) :: maxcyc END SUBROUTINE mgfas END INTERFACE INTERFACE SUBROUTINE mglin(u,ncycle) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u INTEGER(I4B), INTENT(IN) :: ncycle END SUBROUTINE mglin END INTERFACE INTERFACE SUBROUTINE midexp(funk,aa,bb,s,n) USE nrtype REAL(SP), INTENT(IN) :: aa,bb REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION funk(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: funk END FUNCTION funk END INTERFACE END SUBROUTINE midexp END INTERFACE INTERFACE SUBROUTINE midinf(funk,aa,bb,s,n) USE nrtype REAL(SP), INTENT(IN) :: aa,bb REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION funk(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: funk END FUNCTION funk END INTERFACE END SUBROUTINE midinf END INTERFACE INTERFACE SUBROUTINE midpnt(func,a,b,s,n) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END SUBROUTINE midpnt END INTERFACE INTERFACE SUBROUTINE midsql(funk,aa,bb,s,n) USE nrtype REAL(SP), INTENT(IN) :: aa,bb REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION funk(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: funk END FUNCTION funk END INTERFACE END SUBROUTINE midsql END INTERFACE INTERFACE SUBROUTINE midsqu(funk,aa,bb,s,n) USE nrtype REAL(SP), INTENT(IN) :: aa,bb REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION funk(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: funk END FUNCTION funk END INTERFACE END SUBROUTINE midsqu END INTERFACE INTERFACE RECURSIVE SUBROUTINE miser(func,regn,ndim,npts,dith,ave,var) USE nrtype INTERFACE FUNCTION func(x) USE nrtype REAL(SP) :: func REAL(SP), DIMENSION(:), INTENT(IN) :: x END FUNCTION func END INTERFACE REAL(SP), DIMENSION(:), INTENT(IN) :: regn INTEGER(I4B), INTENT(IN) :: ndim,npts REAL(SP), INTENT(IN) :: dith REAL(SP), INTENT(OUT) :: ave,var END SUBROUTINE miser END INTERFACE INTERFACE SUBROUTINE mmid(y,dydx,xs,htot,nstep,yout,derivs) USE nrtype INTEGER(I4B), INTENT(IN) :: nstep REAL(SP), INTENT(IN) :: xs,htot REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx REAL(SP), DIMENSION(:), INTENT(OUT) :: yout INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE mmid END INTERFACE INTERFACE SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func) USE nrtype REAL(SP), INTENT(INOUT) :: ax,bx REAL(SP), INTENT(OUT) :: cx,fa,fb,fc INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE mnbrak END INTERFACE INTERFACE SUBROUTINE mnewt(ntrial,x,tolx,tolf,usrfun) USE nrtype INTEGER(I4B), INTENT(IN) :: ntrial REAL(SP), INTENT(IN) :: tolx,tolf REAL(SP), DIMENSION(:), INTENT(INOUT) :: x INTERFACE SUBROUTINE usrfun(x,fvec,fjac) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(OUT) :: fvec REAL(SP), DIMENSION(:,:), INTENT(OUT) :: fjac END SUBROUTINE usrfun END INTERFACE END SUBROUTINE mnewt END INTERFACE INTERFACE SUBROUTINE moment(data,ave,adev,sdev,var,skew,curt) USE nrtype REAL(SP), INTENT(OUT) :: ave,adev,sdev,var,skew,curt REAL(SP), DIMENSION(:), INTENT(IN) :: data END SUBROUTINE moment END INTERFACE INTERFACE SUBROUTINE mp2dfr(a,s,n,m) USE nrtype INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B), INTENT(OUT) :: m CHARACTER(1), DIMENSION(:), INTENT(INOUT) :: a CHARACTER(1), DIMENSION(:), INTENT(OUT) :: s END SUBROUTINE mp2dfr END INTERFACE INTERFACE SUBROUTINE mpdiv(q,r,u,v,n,m) USE nrtype CHARACTER(1), DIMENSION(:), INTENT(OUT) :: q,r CHARACTER(1), DIMENSION(:), INTENT(IN) :: u,v INTEGER(I4B), INTENT(IN) :: n,m END SUBROUTINE mpdiv END INTERFACE INTERFACE SUBROUTINE mpinv(u,v,n,m) USE nrtype CHARACTER(1), DIMENSION(:), INTENT(OUT) :: u CHARACTER(1), DIMENSION(:), INTENT(IN) :: v INTEGER(I4B), INTENT(IN) :: n,m END SUBROUTINE mpinv END INTERFACE INTERFACE SUBROUTINE mpmul(w,u,v,n,m) USE nrtype CHARACTER(1), DIMENSION(:), INTENT(IN) :: u,v CHARACTER(1), DIMENSION(:), INTENT(OUT) :: w INTEGER(I4B), INTENT(IN) :: n,m END SUBROUTINE mpmul END INTERFACE INTERFACE SUBROUTINE mppi(n) USE nrtype INTEGER(I4B), INTENT(IN) :: n END SUBROUTINE mppi END INTERFACE INTERFACE SUBROUTINE mprove(a,alud,indx,b,x) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,alud INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx REAL(SP), DIMENSION(:), INTENT(IN) :: b REAL(SP), DIMENSION(:), INTENT(INOUT) :: x END SUBROUTINE mprove END INTERFACE INTERFACE SUBROUTINE mpsqrt(w,u,v,n,m) USE nrtype CHARACTER(1), DIMENSION(:), INTENT(OUT) :: w,u CHARACTER(1), DIMENSION(:), INTENT(IN) :: v INTEGER(I4B), INTENT(IN) :: n,m END SUBROUTINE mpsqrt END INTERFACE INTERFACE SUBROUTINE mrqcof(x,y,sig,a,maska,alpha,beta,chisq,funcs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,a,sig REAL(SP), DIMENSION(:), INTENT(OUT) :: beta REAL(SP), DIMENSION(:,:), INTENT(OUT) :: alpha REAL(SP), INTENT(OUT) :: chisq LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska INTERFACE SUBROUTINE funcs(x,a,yfit,dyda) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,a REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda END SUBROUTINE funcs END INTERFACE END SUBROUTINE mrqcof END INTERFACE INTERFACE SUBROUTINE mrqmin(x,y,sig,a,maska,covar,alpha,chisq,funcs,alamda) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig REAL(SP), DIMENSION(:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:,:), INTENT(OUT) :: covar,alpha REAL(SP), INTENT(OUT) :: chisq REAL(SP), INTENT(INOUT) :: alamda LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska INTERFACE SUBROUTINE funcs(x,a,yfit,dyda) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,a REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda END SUBROUTINE funcs END INTERFACE END SUBROUTINE mrqmin END INTERFACE INTERFACE SUBROUTINE newt(x,check) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: x LOGICAL(LGT), INTENT(OUT) :: check END SUBROUTINE newt END INTERFACE INTERFACE SUBROUTINE odeint(ystart,x1,x2,eps,h1,hmin,derivs,rkqs) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: ystart REAL(SP), INTENT(IN) :: x1,x2,eps,h1,hmin INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs !BL SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE rkqs END INTERFACE END SUBROUTINE odeint END INTERFACE INTERFACE SUBROUTINE orthog(anu,alpha,beta,a,b) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: anu,alpha,beta REAL(SP), DIMENSION(:), INTENT(OUT) :: a,b END SUBROUTINE orthog END INTERFACE INTERFACE SUBROUTINE pade(cof,resid) USE nrtype REAL(DP), DIMENSION(:), INTENT(INOUT) :: cof REAL(SP), INTENT(OUT) :: resid END SUBROUTINE pade END INTERFACE INTERFACE FUNCTION pccheb(d) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: d REAL(SP), DIMENSION(size(d)) :: pccheb END FUNCTION pccheb END INTERFACE INTERFACE SUBROUTINE pcshft(a,b,d) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), DIMENSION(:), INTENT(INOUT) :: d END SUBROUTINE pcshft END INTERFACE INTERFACE SUBROUTINE pearsn(x,y,r,prob,z) USE nrtype REAL(SP), INTENT(OUT) :: r,prob,z REAL(SP), DIMENSION(:), INTENT(IN) :: x,y END SUBROUTINE pearsn END INTERFACE INTERFACE SUBROUTINE period(x,y,ofac,hifac,px,py,jmax,prob) USE nrtype INTEGER(I4B), INTENT(OUT) :: jmax REAL(SP), INTENT(IN) :: ofac,hifac REAL(SP), INTENT(OUT) :: prob REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), DIMENSION(:), POINTER :: px,py END SUBROUTINE period END INTERFACE INTERFACE plgndr FUNCTION plgndr_s(l,m,x) USE nrtype INTEGER(I4B), INTENT(IN) :: l,m REAL(SP), INTENT(IN) :: x REAL(SP) :: plgndr_s END FUNCTION plgndr_s !BL FUNCTION plgndr_v(l,m,x) USE nrtype INTEGER(I4B), INTENT(IN) :: l,m REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: plgndr_v END FUNCTION plgndr_v END INTERFACE INTERFACE FUNCTION poidev(xm) USE nrtype REAL(SP), INTENT(IN) :: xm REAL(SP) :: poidev END FUNCTION poidev END INTERFACE INTERFACE FUNCTION polcoe(x,y) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), DIMENSION(size(x)) :: polcoe END FUNCTION polcoe END INTERFACE INTERFACE FUNCTION polcof(xa,ya) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya REAL(SP), DIMENSION(size(xa)) :: polcof END FUNCTION polcof END INTERFACE INTERFACE SUBROUTINE poldiv(u,v,q,r) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: u,v REAL(SP), DIMENSION(:), INTENT(OUT) :: q,r END SUBROUTINE poldiv END INTERFACE INTERFACE SUBROUTINE polin2(x1a,x2a,ya,x1,x2,y,dy) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya REAL(SP), INTENT(IN) :: x1,x2 REAL(SP), INTENT(OUT) :: y,dy END SUBROUTINE polin2 END INTERFACE INTERFACE SUBROUTINE polint(xa,ya,x,y,dy) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: y,dy END SUBROUTINE polint END INTERFACE INTERFACE SUBROUTINE powell(p,xi,ftol,iter,fret) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: p REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: xi INTEGER(I4B), INTENT(OUT) :: iter REAL(SP), INTENT(IN) :: ftol REAL(SP), INTENT(OUT) :: fret END SUBROUTINE powell END INTERFACE INTERFACE FUNCTION predic(data,d,nfut) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data,d INTEGER(I4B), INTENT(IN) :: nfut REAL(SP), DIMENSION(nfut) :: predic END FUNCTION predic END INTERFACE INTERFACE FUNCTION probks(alam) USE nrtype REAL(SP), INTENT(IN) :: alam REAL(SP) :: probks END FUNCTION probks END INTERFACE INTERFACE psdes SUBROUTINE psdes_s(lword,rword) USE nrtype INTEGER(I4B), INTENT(INOUT) :: lword,rword END SUBROUTINE psdes_s !BL SUBROUTINE psdes_v(lword,rword) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: lword,rword END SUBROUTINE psdes_v END INTERFACE INTERFACE SUBROUTINE pwt(a,isign) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: a INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE pwt END INTERFACE INTERFACE SUBROUTINE pwtset(n) USE nrtype INTEGER(I4B), INTENT(IN) :: n END SUBROUTINE pwtset END INTERFACE INTERFACE pythag FUNCTION pythag_dp(a,b) USE nrtype REAL(DP), INTENT(IN) :: a,b REAL(DP) :: pythag_dp END FUNCTION pythag_dp !BL FUNCTION pythag_sp(a,b) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP) :: pythag_sp END FUNCTION pythag_sp END INTERFACE INTERFACE SUBROUTINE pzextr(iest,xest,yest,yz,dy) USE nrtype INTEGER(I4B), INTENT(IN) :: iest REAL(SP), INTENT(IN) :: xest REAL(SP), DIMENSION(:), INTENT(IN) :: yest REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy END SUBROUTINE pzextr END INTERFACE !!! FB: ! INTERFACE ! FUNCTION qgaus(func,a,b) ! USE nrtype ! REAL(SP), INTENT(IN) :: a,b ! REAL(SP) :: qgaus ! INTERFACE ! FUNCTION func(x) ! USE nrtype ! REAL(SP), DIMENSION(:), INTENT(IN) :: x ! REAL(SP), DIMENSION(size(x)) :: func ! END FUNCTION func ! END INTERFACE ! END FUNCTION qgaus ! END INTERFACE !!! /FB INTERFACE SUBROUTINE qrdcmp(a,c,d,sing) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:), INTENT(OUT) :: c,d LOGICAL(LGT), INTENT(OUT) :: sing END SUBROUTINE qrdcmp END INTERFACE INTERFACE FUNCTION qromb(func,a,b) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP) :: qromb INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END FUNCTION qromb END INTERFACE INTERFACE FUNCTION qromo(func,a,b,choose) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP) :: qromo INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE INTERFACE SUBROUTINE choose(funk,aa,bb,s,n) USE nrtype REAL(SP), INTENT(IN) :: aa,bb REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION funk(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: funk END FUNCTION funk END INTERFACE END SUBROUTINE choose END INTERFACE END FUNCTION qromo END INTERFACE INTERFACE SUBROUTINE qroot(p,b,c,eps) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: p REAL(SP), INTENT(INOUT) :: b,c REAL(SP), INTENT(IN) :: eps END SUBROUTINE qroot END INTERFACE INTERFACE SUBROUTINE qrsolv(a,c,d,b) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: a REAL(SP), DIMENSION(:), INTENT(IN) :: c,d REAL(SP), DIMENSION(:), INTENT(INOUT) :: b END SUBROUTINE qrsolv END INTERFACE INTERFACE SUBROUTINE qrupdt(r,qt,u,v) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: r,qt REAL(SP), DIMENSION(:), INTENT(INOUT) :: u REAL(SP), DIMENSION(:), INTENT(IN) :: v END SUBROUTINE qrupdt END INTERFACE INTERFACE FUNCTION qsimp(func,a,b) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP) :: qsimp INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END FUNCTION qsimp END INTERFACE INTERFACE FUNCTION qtrap(func,a,b) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP) :: qtrap INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END FUNCTION qtrap END INTERFACE INTERFACE SUBROUTINE quadct(x,y,xx,yy,fa,fb,fc,fd) USE nrtype REAL(SP), INTENT(IN) :: x,y REAL(SP), DIMENSION(:), INTENT(IN) :: xx,yy REAL(SP), INTENT(OUT) :: fa,fb,fc,fd END SUBROUTINE quadct END INTERFACE INTERFACE SUBROUTINE quadmx(a) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(OUT) :: a END SUBROUTINE quadmx END INTERFACE INTERFACE SUBROUTINE quadvl(x,y,fa,fb,fc,fd) USE nrtype REAL(SP), INTENT(IN) :: x,y REAL(SP), INTENT(OUT) :: fa,fb,fc,fd END SUBROUTINE quadvl END INTERFACE INTERFACE FUNCTION ran(idum) INTEGER(selected_int_kind(9)), INTENT(INOUT) :: idum REAL :: ran END FUNCTION ran END INTERFACE INTERFACE ran0 SUBROUTINE ran0_s(harvest) USE nrtype REAL(SP), INTENT(OUT) :: harvest END SUBROUTINE ran0_s !BL SUBROUTINE ran0_v(harvest) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest END SUBROUTINE ran0_v END INTERFACE INTERFACE ran1 SUBROUTINE ran1_s(harvest) USE nrtype REAL(SP), INTENT(OUT) :: harvest END SUBROUTINE ran1_s !BL SUBROUTINE ran1_v(harvest) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest END SUBROUTINE ran1_v END INTERFACE INTERFACE ran2 SUBROUTINE ran2_s(harvest) USE nrtype REAL(SP), INTENT(OUT) :: harvest END SUBROUTINE ran2_s !BL SUBROUTINE ran2_v(harvest) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest END SUBROUTINE ran2_v END INTERFACE INTERFACE ran3 SUBROUTINE ran3_s(harvest) USE nrtype REAL(SP), INTENT(OUT) :: harvest END SUBROUTINE ran3_s !BL SUBROUTINE ran3_v(harvest) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest END SUBROUTINE ran3_v END INTERFACE INTERFACE SUBROUTINE ratint(xa,ya,x,y,dy) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: y,dy END SUBROUTINE ratint END INTERFACE INTERFACE SUBROUTINE ratlsq(func,a,b,mm,kk,cof,dev) USE nrtype REAL(DP), INTENT(IN) :: a,b INTEGER(I4B), INTENT(IN) :: mm,kk REAL(DP), DIMENSION(:), INTENT(OUT) :: cof REAL(DP), INTENT(OUT) :: dev INTERFACE FUNCTION func(x) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: x REAL(DP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END SUBROUTINE ratlsq END INTERFACE INTERFACE ratval FUNCTION ratval_s(x,cof,mm,kk) USE nrtype REAL(DP), INTENT(IN) :: x INTEGER(I4B), INTENT(IN) :: mm,kk REAL(DP), DIMENSION(mm+kk+1), INTENT(IN) :: cof REAL(DP) :: ratval_s END FUNCTION ratval_s !BL FUNCTION ratval_v(x,cof,mm,kk) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: x INTEGER(I4B), INTENT(IN) :: mm,kk REAL(DP), DIMENSION(mm+kk+1), INTENT(IN) :: cof REAL(DP), DIMENSION(size(x)) :: ratval_v END FUNCTION ratval_v END INTERFACE INTERFACE rc FUNCTION rc_s(x,y) USE nrtype REAL(SP), INTENT(IN) :: x,y REAL(SP) :: rc_s END FUNCTION rc_s !BL FUNCTION rc_v(x,y) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), DIMENSION(size(x)) :: rc_v END FUNCTION rc_v END INTERFACE INTERFACE rd FUNCTION rd_s(x,y,z) USE nrtype REAL(SP), INTENT(IN) :: x,y,z REAL(SP) :: rd_s END FUNCTION rd_s !BL FUNCTION rd_v(x,y,z) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z REAL(SP), DIMENSION(size(x)) :: rd_v END FUNCTION rd_v END INTERFACE INTERFACE realft SUBROUTINE realft_dp(data,isign,zdata) USE nrtype REAL(DP), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign COMPLEX(DPC), DIMENSION(:), OPTIONAL, TARGET :: zdata END SUBROUTINE realft_dp !BL SUBROUTINE realft_sp(data,isign,zdata) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign COMPLEX(SPC), DIMENSION(:), OPTIONAL, TARGET :: zdata END SUBROUTINE realft_sp END INTERFACE INTERFACE RECURSIVE FUNCTION recur1(a,b) RESULT(u) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,b REAL(SP), DIMENSION(size(a)) :: u END FUNCTION recur1 END INTERFACE INTERFACE FUNCTION recur2(a,b,c) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c REAL(SP), DIMENSION(size(a)) :: recur2 END FUNCTION recur2 END INTERFACE INTERFACE SUBROUTINE relax(u,rhs) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u REAL(DP), DIMENSION(:,:), INTENT(IN) :: rhs END SUBROUTINE relax END INTERFACE INTERFACE SUBROUTINE relax2(u,rhs) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u REAL(DP), DIMENSION(:,:), INTENT(IN) :: rhs END SUBROUTINE relax2 END INTERFACE INTERFACE FUNCTION resid(u,rhs) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: u,rhs REAL(DP), DIMENSION(size(u,1),size(u,1)) :: resid END FUNCTION resid END INTERFACE INTERFACE rf FUNCTION rf_s(x,y,z) USE nrtype REAL(SP), INTENT(IN) :: x,y,z REAL(SP) :: rf_s END FUNCTION rf_s !BL FUNCTION rf_v(x,y,z) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z REAL(SP), DIMENSION(size(x)) :: rf_v END FUNCTION rf_v END INTERFACE INTERFACE rj FUNCTION rj_s(x,y,z,p) USE nrtype REAL(SP), INTENT(IN) :: x,y,z,p REAL(SP) :: rj_s END FUNCTION rj_s !BL FUNCTION rj_v(x,y,z,p) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z,p REAL(SP), DIMENSION(size(x)) :: rj_v END FUNCTION rj_v END INTERFACE INTERFACE SUBROUTINE rk4(y,dydx,x,h,yout,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx REAL(SP), INTENT(IN) :: x,h REAL(SP), DIMENSION(:), INTENT(OUT) :: yout INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE rk4 END INTERFACE INTERFACE SUBROUTINE rkck(y,dydx,x,h,yout,yerr,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx REAL(SP), INTENT(IN) :: x,h REAL(SP), DIMENSION(:), INTENT(OUT) :: yout,yerr INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE rkck END INTERFACE INTERFACE SUBROUTINE rkdumb(vstart,x1,x2,nstep,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: vstart REAL(SP), INTENT(IN) :: x1,x2 INTEGER(I4B), INTENT(IN) :: nstep INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE rkdumb END INTERFACE INTERFACE SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE rkqs END INTERFACE INTERFACE SUBROUTINE rlft2(data,spec,speq,isign) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: data COMPLEX(SPC), DIMENSION(:,:), INTENT(OUT) :: spec COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: speq INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE rlft2 END INTERFACE INTERFACE SUBROUTINE rlft3(data,spec,speq,isign) USE nrtype REAL(SP), DIMENSION(:,:,:), INTENT(INOUT) :: data COMPLEX(SPC), DIMENSION(:,:,:), INTENT(OUT) :: spec COMPLEX(SPC), DIMENSION(:,:), INTENT(OUT) :: speq INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE rlft3 END INTERFACE INTERFACE SUBROUTINE rotate(r,qt,i,a,b) USE nrtype REAL(SP), DIMENSION(:,:), TARGET, INTENT(INOUT) :: r,qt INTEGER(I4B), INTENT(IN) :: i REAL(SP), INTENT(IN) :: a,b END SUBROUTINE rotate END INTERFACE INTERFACE SUBROUTINE rsolv(a,d,b) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: a REAL(SP), DIMENSION(:), INTENT(IN) :: d REAL(SP), DIMENSION(:), INTENT(INOUT) :: b END SUBROUTINE rsolv END INTERFACE INTERFACE FUNCTION rstrct(uf) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: uf REAL(DP), DIMENSION((size(uf,1)+1)/2,(size(uf,1)+1)/2) :: rstrct END FUNCTION rstrct END INTERFACE INTERFACE FUNCTION rtbis(func,x1,x2,xacc) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,xacc REAL(SP) :: rtbis INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION rtbis END INTERFACE INTERFACE FUNCTION rtflsp(func,x1,x2,xacc) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,xacc REAL(SP) :: rtflsp INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION rtflsp END INTERFACE INTERFACE FUNCTION rtnewt(funcd,x1,x2,xacc) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,xacc REAL(SP) :: rtnewt INTERFACE SUBROUTINE funcd(x,fval,fderiv) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: fval,fderiv END SUBROUTINE funcd END INTERFACE END FUNCTION rtnewt END INTERFACE INTERFACE FUNCTION rtsafe(funcd,x1,x2,xacc) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,xacc REAL(SP) :: rtsafe INTERFACE SUBROUTINE funcd(x,fval,fderiv) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: fval,fderiv END SUBROUTINE funcd END INTERFACE END FUNCTION rtsafe END INTERFACE INTERFACE FUNCTION rtsec(func,x1,x2,xacc) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,xacc REAL(SP) :: rtsec INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION rtsec END INTERFACE INTERFACE SUBROUTINE rzextr(iest,xest,yest,yz,dy) USE nrtype INTEGER(I4B), INTENT(IN) :: iest REAL(SP), INTENT(IN) :: xest REAL(SP), DIMENSION(:), INTENT(IN) :: yest REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy END SUBROUTINE rzextr END INTERFACE INTERFACE FUNCTION savgol(nl,nrr,ld,m) USE nrtype INTEGER(I4B), INTENT(IN) :: nl,nrr,ld,m REAL(SP), DIMENSION(nl+nrr+1) :: savgol END FUNCTION savgol END INTERFACE INTERFACE SUBROUTINE scrsho(func) USE nrtype INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE scrsho END INTERFACE INTERFACE FUNCTION select(k,arr) USE nrtype INTEGER(I4B), INTENT(IN) :: k REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr REAL(SP) :: select END FUNCTION select END INTERFACE INTERFACE FUNCTION select_bypack(k,arr) USE nrtype INTEGER(I4B), INTENT(IN) :: k REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr REAL(SP) :: select_bypack END FUNCTION select_bypack END INTERFACE INTERFACE SUBROUTINE select_heap(arr,heap) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: arr REAL(SP), DIMENSION(:), INTENT(OUT) :: heap END SUBROUTINE select_heap END INTERFACE INTERFACE FUNCTION select_inplace(k,arr) USE nrtype INTEGER(I4B), INTENT(IN) :: k REAL(SP), DIMENSION(:), INTENT(IN) :: arr REAL(SP) :: select_inplace END FUNCTION select_inplace END INTERFACE INTERFACE SUBROUTINE simplx(a,m1,m2,m3,icase,izrov,iposv) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a INTEGER(I4B), INTENT(IN) :: m1,m2,m3 INTEGER(I4B), INTENT(OUT) :: icase INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: izrov,iposv END SUBROUTINE simplx END INTERFACE INTERFACE SUBROUTINE simpr(y,dydx,dfdx,dfdy,xs,htot,nstep,yout,derivs) USE nrtype REAL(SP), INTENT(IN) :: xs,htot REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx,dfdx REAL(SP), DIMENSION(:,:), INTENT(IN) :: dfdy INTEGER(I4B), INTENT(IN) :: nstep REAL(SP), DIMENSION(:), INTENT(OUT) :: yout INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE simpr END INTERFACE INTERFACE SUBROUTINE sinft(y) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y END SUBROUTINE sinft END INTERFACE INTERFACE SUBROUTINE slvsm2(u,rhs) USE nrtype REAL(DP), DIMENSION(3,3), INTENT(OUT) :: u REAL(DP), DIMENSION(3,3), INTENT(IN) :: rhs END SUBROUTINE slvsm2 END INTERFACE INTERFACE SUBROUTINE slvsml(u,rhs) USE nrtype REAL(DP), DIMENSION(3,3), INTENT(OUT) :: u REAL(DP), DIMENSION(3,3), INTENT(IN) :: rhs END SUBROUTINE slvsml END INTERFACE INTERFACE SUBROUTINE sncndn(uu,emmc,sn,cn,dn) USE nrtype REAL(SP), INTENT(IN) :: uu,emmc REAL(SP), INTENT(OUT) :: sn,cn,dn END SUBROUTINE sncndn END INTERFACE INTERFACE FUNCTION snrm(sx,itol) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: sx INTEGER(I4B), INTENT(IN) :: itol REAL(DP) :: snrm END FUNCTION snrm END INTERFACE INTERFACE SUBROUTINE sobseq(x,init) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: x INTEGER(I4B), OPTIONAL, INTENT(IN) :: init END SUBROUTINE sobseq END INTERFACE INTERFACE SUBROUTINE solvde(itmax,conv,slowc,scalv,indexv,nb,y) USE nrtype INTEGER(I4B), INTENT(IN) :: itmax,nb REAL(SP), INTENT(IN) :: conv,slowc REAL(SP), DIMENSION(:), INTENT(IN) :: scalv INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: y END SUBROUTINE solvde END INTERFACE INTERFACE SUBROUTINE sor(a,b,c,d,e,f,u,rjac) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: a,b,c,d,e,f REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u REAL(DP), INTENT(IN) :: rjac END SUBROUTINE sor END INTERFACE INTERFACE SUBROUTINE sort(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort END INTERFACE INTERFACE SUBROUTINE sort2(arr,slave) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr,slave END SUBROUTINE sort2 END INTERFACE INTERFACE SUBROUTINE sort3(arr,slave1,slave2) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr,slave1,slave2 END SUBROUTINE sort3 END INTERFACE INTERFACE SUBROUTINE sort_bypack(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort_bypack END INTERFACE INTERFACE SUBROUTINE sort_byreshape(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort_byreshape END INTERFACE INTERFACE SUBROUTINE sort_heap(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort_heap END INTERFACE INTERFACE SUBROUTINE sort_pick(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort_pick END INTERFACE INTERFACE SUBROUTINE sort_radix(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort_radix END INTERFACE INTERFACE SUBROUTINE sort_shell(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort_shell END INTERFACE INTERFACE SUBROUTINE spctrm(p,k,ovrlap,unit,n_window) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: p INTEGER(I4B), INTENT(IN) :: k LOGICAL(LGT), INTENT(IN) :: ovrlap INTEGER(I4B), OPTIONAL, INTENT(IN) :: n_window,unit END SUBROUTINE spctrm END INTERFACE INTERFACE SUBROUTINE spear(data1,data2,d,zd,probd,rs,probrs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 REAL(SP), INTENT(OUT) :: d,zd,probd,rs,probrs END SUBROUTINE spear END INTERFACE INTERFACE sphbes SUBROUTINE sphbes_s(n,x,sj,sy,sjp,syp) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: sj,sy,sjp,syp END SUBROUTINE sphbes_s !BL SUBROUTINE sphbes_v(n,x,sj,sy,sjp,syp) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(OUT) :: sj,sy,sjp,syp END SUBROUTINE sphbes_v END INTERFACE INTERFACE SUBROUTINE splie2(x1a,x2a,ya,y2a) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya REAL(SP), DIMENSION(:,:), INTENT(OUT) :: y2a END SUBROUTINE splie2 END INTERFACE INTERFACE FUNCTION splin2(x1a,x2a,ya,y2a,x1,x2) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya,y2a REAL(SP), INTENT(IN) :: x1,x2 REAL(SP) :: splin2 END FUNCTION splin2 END INTERFACE INTERFACE SUBROUTINE spline(x,y,yp1,ypn,y2) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), INTENT(IN) :: yp1,ypn REAL(SP), DIMENSION(:), INTENT(OUT) :: y2 END SUBROUTINE spline END INTERFACE INTERFACE FUNCTION splint(xa,ya,y2a,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya,y2a REAL(SP), INTENT(IN) :: x REAL(SP) :: splint END FUNCTION splint END INTERFACE INTERFACE sprsax SUBROUTINE sprsax_dp(sa,x,b) USE nrtype TYPE(sprs2_dp), INTENT(IN) :: sa REAL(DP), DIMENSION (:), INTENT(IN) :: x REAL(DP), DIMENSION (:), INTENT(OUT) :: b END SUBROUTINE sprsax_dp !BL SUBROUTINE sprsax_sp(sa,x,b) USE nrtype TYPE(sprs2_sp), INTENT(IN) :: sa REAL(SP), DIMENSION (:), INTENT(IN) :: x REAL(SP), DIMENSION (:), INTENT(OUT) :: b END SUBROUTINE sprsax_sp END INTERFACE INTERFACE sprsdiag SUBROUTINE sprsdiag_dp(sa,b) USE nrtype TYPE(sprs2_dp), INTENT(IN) :: sa REAL(DP), DIMENSION(:), INTENT(OUT) :: b END SUBROUTINE sprsdiag_dp !BL SUBROUTINE sprsdiag_sp(sa,b) USE nrtype TYPE(sprs2_sp), INTENT(IN) :: sa REAL(SP), DIMENSION(:), INTENT(OUT) :: b END SUBROUTINE sprsdiag_sp END INTERFACE INTERFACE sprsin SUBROUTINE sprsin_sp(a,thresh,sa) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: a REAL(SP), INTENT(IN) :: thresh TYPE(sprs2_sp), INTENT(OUT) :: sa END SUBROUTINE sprsin_sp !BL SUBROUTINE sprsin_dp(a,thresh,sa) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: a REAL(DP), INTENT(IN) :: thresh TYPE(sprs2_dp), INTENT(OUT) :: sa END SUBROUTINE sprsin_dp END INTERFACE INTERFACE SUBROUTINE sprstp(sa) USE nrtype TYPE(sprs2_sp), INTENT(INOUT) :: sa END SUBROUTINE sprstp END INTERFACE INTERFACE sprstx SUBROUTINE sprstx_dp(sa,x,b) USE nrtype TYPE(sprs2_dp), INTENT(IN) :: sa REAL(DP), DIMENSION (:), INTENT(IN) :: x REAL(DP), DIMENSION (:), INTENT(OUT) :: b END SUBROUTINE sprstx_dp !BL SUBROUTINE sprstx_sp(sa,x,b) USE nrtype TYPE(sprs2_sp), INTENT(IN) :: sa REAL(SP), DIMENSION (:), INTENT(IN) :: x REAL(SP), DIMENSION (:), INTENT(OUT) :: b END SUBROUTINE sprstx_sp END INTERFACE INTERFACE SUBROUTINE stifbs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE stifbs END INTERFACE INTERFACE SUBROUTINE stiff(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE stiff END INTERFACE INTERFACE SUBROUTINE stoerm(y,d2y,xs,htot,nstep,yout,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: y,d2y REAL(SP), INTENT(IN) :: xs,htot INTEGER(I4B), INTENT(IN) :: nstep REAL(SP), DIMENSION(:), INTENT(OUT) :: yout INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE stoerm END INTERFACE INTERFACE svbksb SUBROUTINE svbksb_dp(u,w,v,b,x) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: u,v REAL(DP), DIMENSION(:), INTENT(IN) :: w,b REAL(DP), DIMENSION(:), INTENT(OUT) :: x END SUBROUTINE svbksb_dp !BL SUBROUTINE svbksb_sp(u,w,v,b,x) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: u,v REAL(SP), DIMENSION(:), INTENT(IN) :: w,b REAL(SP), DIMENSION(:), INTENT(OUT) :: x END SUBROUTINE svbksb_sp END INTERFACE INTERFACE svdcmp SUBROUTINE svdcmp_dp(a,w,v) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(DP), DIMENSION(:), INTENT(OUT) :: w REAL(DP), DIMENSION(:,:), INTENT(OUT) :: v END SUBROUTINE svdcmp_dp !BL SUBROUTINE svdcmp_sp(a,w,v) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:), INTENT(OUT) :: w REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v END SUBROUTINE svdcmp_sp END INTERFACE INTERFACE SUBROUTINE svdfit(x,y,sig,a,v,w,chisq,funcs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig REAL(SP), DIMENSION(:), INTENT(OUT) :: a,w REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v REAL(SP), INTENT(OUT) :: chisq INTERFACE FUNCTION funcs(x,n) USE nrtype REAL(SP), INTENT(IN) :: x INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(n) :: funcs END FUNCTION funcs END INTERFACE END SUBROUTINE svdfit END INTERFACE INTERFACE SUBROUTINE svdvar(v,w,cvm) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: v REAL(SP), DIMENSION(:), INTENT(IN) :: w REAL(SP), DIMENSION(:,:), INTENT(OUT) :: cvm END SUBROUTINE svdvar END INTERFACE INTERFACE FUNCTION toeplz(r,y) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: r,y REAL(SP), DIMENSION(size(y)) :: toeplz END FUNCTION toeplz END INTERFACE INTERFACE SUBROUTINE tptest(data1,data2,t,prob) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 REAL(SP), INTENT(OUT) :: t,prob END SUBROUTINE tptest END INTERFACE INTERFACE SUBROUTINE tqli(d,e,z) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: d,e REAL(SP), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: z END SUBROUTINE tqli END INTERFACE INTERFACE SUBROUTINE trapzd(func,a,b,s,n) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END SUBROUTINE trapzd END INTERFACE INTERFACE SUBROUTINE tred2(a,d,e,novectors) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:), INTENT(OUT) :: d,e LOGICAL(LGT), OPTIONAL, INTENT(IN) :: novectors END SUBROUTINE tred2 END INTERFACE ! On a purely serial machine, for greater efficiency, remove ! the generic name tridag from the following interface, ! and put it on the next one after that. INTERFACE tridag RECURSIVE SUBROUTINE tridag_par(a,b,c,r,u) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r REAL(SP), DIMENSION(:), INTENT(OUT) :: u END SUBROUTINE tridag_par END INTERFACE INTERFACE SUBROUTINE tridag_ser(a,b,c,r,u) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r REAL(SP), DIMENSION(:), INTENT(OUT) :: u END SUBROUTINE tridag_ser END INTERFACE INTERFACE SUBROUTINE ttest(data1,data2,t,prob) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 REAL(SP), INTENT(OUT) :: t,prob END SUBROUTINE ttest END INTERFACE INTERFACE SUBROUTINE tutest(data1,data2,t,prob) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 REAL(SP), INTENT(OUT) :: t,prob END SUBROUTINE tutest END INTERFACE INTERFACE SUBROUTINE twofft(data1,data2,fft1,fft2) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: fft1,fft2 END SUBROUTINE twofft END INTERFACE INTERFACE FUNCTION vander(x,q) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: x,q REAL(DP), DIMENSION(size(x)) :: vander END FUNCTION vander END INTERFACE INTERFACE SUBROUTINE vegas(region,func,init,ncall,itmx,nprn,tgral,sd,chi2a) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: region INTEGER(I4B), INTENT(IN) :: init,ncall,itmx,nprn REAL(SP), INTENT(OUT) :: tgral,sd,chi2a INTERFACE FUNCTION func(pt,wgt) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: pt REAL(SP), INTENT(IN) :: wgt REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE vegas END INTERFACE INTERFACE SUBROUTINE voltra(t0,h,t,f,g,ak) USE nrtype REAL(SP), INTENT(IN) :: t0,h REAL(SP), DIMENSION(:), INTENT(OUT) :: t REAL(SP), DIMENSION(:,:), INTENT(OUT) :: f INTERFACE FUNCTION g(t) USE nrtype REAL(SP), INTENT(IN) :: t REAL(SP), DIMENSION(:), POINTER :: g END FUNCTION g !BL FUNCTION ak(t,s) USE nrtype REAL(SP), INTENT(IN) :: t,s REAL(SP), DIMENSION(:,:), POINTER :: ak END FUNCTION ak END INTERFACE END SUBROUTINE voltra END INTERFACE INTERFACE SUBROUTINE wt1(a,isign,wtstep) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: a INTEGER(I4B), INTENT(IN) :: isign INTERFACE SUBROUTINE wtstep(a,isign) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: a INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE wtstep END INTERFACE END SUBROUTINE wt1 END INTERFACE INTERFACE SUBROUTINE wtn(a,nn,isign,wtstep) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: a INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn INTEGER(I4B), INTENT(IN) :: isign INTERFACE SUBROUTINE wtstep(a,isign) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: a INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE wtstep END INTERFACE END SUBROUTINE wtn END INTERFACE INTERFACE FUNCTION wwghts(n,h,kermom) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: h REAL(SP), DIMENSION(n) :: wwghts INTERFACE FUNCTION kermom(y,m) USE nrtype REAL(DP), INTENT(IN) :: y INTEGER(I4B), INTENT(IN) :: m REAL(DP), DIMENSION(m) :: kermom END FUNCTION kermom END INTERFACE END FUNCTION wwghts END INTERFACE INTERFACE SUBROUTINE zbrac(func,x1,x2,succes) USE nrtype REAL(SP), INTENT(INOUT) :: x1,x2 LOGICAL(LGT), INTENT(OUT) :: succes INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE zbrac END INTERFACE INTERFACE SUBROUTINE zbrak(func,x1,x2,n,xb1,xb2,nb) USE nrtype INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B), INTENT(OUT) :: nb REAL(SP), INTENT(IN) :: x1,x2 REAL(SP), DIMENSION(:), POINTER :: xb1,xb2 INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE zbrak END INTERFACE INTERFACE FUNCTION zbrent(func,x1,x2,tol) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,tol REAL(SP) :: zbrent INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION zbrent END INTERFACE INTERFACE SUBROUTINE zrhqr(a,rtr,rti) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a REAL(SP), DIMENSION(:), INTENT(OUT) :: rtr,rti END SUBROUTINE zrhqr END INTERFACE INTERFACE FUNCTION zriddr(func,x1,x2,xacc) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,xacc REAL(SP) :: zriddr INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION zriddr END INTERFACE INTERFACE SUBROUTINE zroots(a,roots,polish) USE nrtype COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: roots LOGICAL(LGT), INTENT(IN) :: polish END SUBROUTINE zroots END INTERFACE END MODULE nr SUBROUTINE rkck(y,dydx,x,h,yout,yerr,derivs) USE nrtype; USE nrutil, ONLY : assert_eq IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx REAL(SP), INTENT(IN) :: x,h REAL(SP), DIMENSION(:), INTENT(OUT) :: yout,yerr INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype IMPLICIT NONE REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE INTEGER(I4B) :: ndum REAL(SP), DIMENSION(size(y)) :: ak2,ak3,ak4,ak5,ak6,ytemp REAL(SP), PARAMETER :: A2=0.2_sp,A3=0.3_sp,A4=0.6_sp,A5=1.0_sp,& A6=0.875_sp,B21=0.2_sp,B31=3.0_sp/40.0_sp,B32=9.0_sp/40.0_sp,& B41=0.3_sp,B42=-0.9_sp,B43=1.2_sp,B51=-11.0_sp/54.0_sp,& B52=2.5_sp,B53=-70.0_sp/27.0_sp,B54=35.0_sp/27.0_sp,& B61=1631.0_sp/55296.0_sp,B62=175.0_sp/512.0_sp,& B63=575.0_sp/13824.0_sp,B64=44275.0_sp/110592.0_sp,& B65=253.0_sp/4096.0_sp,C1=37.0_sp/378.0_sp,& C3=250.0_sp/621.0_sp,C4=125.0_sp/594.0_sp,& C6=512.0_sp/1771.0_sp,DC1=C1-2825.0_sp/27648.0_sp,& DC3=C3-18575.0_sp/48384.0_sp,DC4=C4-13525.0_sp/55296.0_sp,& DC5=-277.0_sp/14336.0_sp,DC6=C6-0.25_sp ndum=assert_eq(size(y),size(dydx),size(yout),size(yerr),'rkck') ytemp=y+B21*h*dydx call derivs(x+A2*h,ytemp,ak2) ytemp=y+h*(B31*dydx+B32*ak2) call derivs(x+A3*h,ytemp,ak3) ytemp=y+h*(B41*dydx+B42*ak2+B43*ak3) call derivs(x+A4*h,ytemp,ak4) ytemp=y+h*(B51*dydx+B52*ak2+B53*ak3+B54*ak4) call derivs(x+A5*h,ytemp,ak5) ytemp=y+h*(B61*dydx+B62*ak2+B63*ak3+B64*ak4+B65*ak5) call derivs(x+A6*h,ytemp,ak6) yout=y+h*(C1*dydx+C3*ak3+C4*ak4+C6*ak6) yerr=h*(DC1*dydx+DC3*ak3+DC4*ak4+DC5*ak5+DC6*ak6) END SUBROUTINE rkck SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype; USE nrutil, ONLY : assert_eq,nrerror USE nr, ONLY : rkck IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype IMPLICIT NONE REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE INTEGER(I4B) :: ndum REAL(SP) :: errmax,h,htemp,xnew REAL(SP), DIMENSION(size(y)) :: yerr,ytemp REAL(SP), PARAMETER :: SAFETY=0.9_sp,PGROW=-0.2_sp,PSHRNK=-0.25_sp,& ERRCON=1.89e-4 ndum=assert_eq(size(y),size(dydx),size(yscal),'rkqs') h=htry do call rkck(y,dydx,x,h,ytemp,yerr,derivs) errmax=maxval(abs(yerr(:)/yscal(:)))/eps if (errmax <= 1.0) exit htemp=SAFETY*h*(errmax**PSHRNK) h=sign(max(abs(htemp),0.1_sp*abs(h)),h) xnew=x+h if (xnew == x) call nrerror('stepsize underflow in rkqs') end do if (errmax > ERRCON) then hnext=SAFETY*h*(errmax**PGROW) else hnext=5.0_sp*h end if hdid=h x=x+h y(:)=ytemp(:) END SUBROUTINE rkqs SUBROUTINE mmid(y,dydx,xs,htot,nstep,yout,derivs) USE nrtype; USE nrutil, ONLY : assert_eq,swap IMPLICIT NONE INTEGER(I4B), INTENT(IN) :: nstep REAL(SP), INTENT(IN) :: xs,htot REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx REAL(SP), DIMENSION(:), INTENT(OUT) :: yout INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype IMPLICIT NONE REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE INTEGER(I4B) :: n,ndum REAL(SP) :: h,h2,x REAL(SP), DIMENSION(size(y)) :: ym,yn ndum=assert_eq(size(y),size(dydx),size(yout),'mmid') h=htot/nstep ym=y yn=y+h*dydx x=xs+h call derivs(x,yn,yout) h2=2.0_sp*h do n=2,nstep call swap(ym,yn) yn=yn+h2*yout x=x+h call derivs(x,yn,yout) end do yout=0.5_sp*(ym+yn+h*yout) END SUBROUTINE mmid SUBROUTINE pzextr(iest,xest,yest,yz,dy) USE nrtype; USE nrutil, ONLY : assert_eq,nrerror IMPLICIT NONE INTEGER(I4B), INTENT(IN) :: iest REAL(SP), INTENT(IN) :: xest REAL(SP), DIMENSION(:), INTENT(IN) :: yest REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy INTEGER(I4B), PARAMETER :: IEST_MAX=16 INTEGER(I4B) :: j,nv INTEGER(I4B), SAVE :: nvold=-1 REAL(SP) :: delta,f1,f2 REAL(SP), DIMENSION(size(yz)) :: d,tmp,q REAL(SP), DIMENSION(IEST_MAX), SAVE :: x REAL(SP), DIMENSION(:,:), ALLOCATABLE, SAVE :: qcol nv=assert_eq(size(yz),size(yest),size(dy),'pzextr') if (iest > IEST_MAX) call & nrerror('pzextr: probable misuse, too much extrapolation') if (nv /= nvold) then if (allocated(qcol)) deallocate(qcol) allocate(qcol(nv,IEST_MAX)) nvold=nv end if x(iest)=xest dy(:)=yest(:) yz(:)=yest(:) if (iest == 1) then qcol(:,1)=yest(:) else d(:)=yest(:) do j=1,iest-1 delta=1.0_sp/(x(iest-j)-xest) f1=xest*delta f2=x(iest-j)*delta q(:)=qcol(:,j) qcol(:,j)=dy(:) tmp(:)=d(:)-q(:) dy(:)=f1*tmp(:) d(:)=f2*tmp(:) yz(:)=yz(:)+dy(:) end do qcol(:,iest)=dy(:) end if END SUBROUTINE pzextr SUBROUTINE bsstep(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype; USE nrutil, ONLY : arth,assert_eq,cumsum,iminloc,nrerror,& outerdiff,outerprod,upper_triangle USE nr, ONLY : mmid,pzextr IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype IMPLICIT NONE REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE INTEGER(I4B), PARAMETER :: IMAX=9, KMAXX=IMAX-1 REAL(SP), PARAMETER :: SAFE1=0.25_sp,SAFE2=0.7_sp,REDMAX=1.0e-5_sp,& REDMIN=0.7_sp,TINY=1.0e-30_sp,SCALMX=0.1_sp INTEGER(I4B) :: k,km,ndum INTEGER(I4B), DIMENSION(IMAX) :: nseq = (/ 2,4,6,8,10,12,14,16,18 /) INTEGER(I4B), SAVE :: kopt,kmax REAL(SP), DIMENSION(KMAXX,KMAXX), SAVE :: alf REAL(SP), DIMENSION(KMAXX) :: err REAL(SP), DIMENSION(IMAX), SAVE :: a REAL(SP), SAVE :: epsold = -1.0_sp,xnew REAL(SP) :: eps1,errmax,fact,h,red,scale,wrkmin,xest REAL(SP), DIMENSION(size(y)) :: yerr,ysav,yseq LOGICAL(LGT) :: reduct LOGICAL(LGT), SAVE :: first=.true. ndum=assert_eq(size(y),size(dydx),size(yscal),'bsstep') if (eps /= epsold) then hnext=-1.0e29_sp xnew=-1.0e29_sp eps1=SAFE1*eps a(:)=cumsum(nseq,1) where (upper_triangle(KMAXX,KMAXX)) alf=eps1** & (outerdiff(a(2:),a(2:))/outerprod(arth( & 3.0_sp,2.0_sp,KMAXX),(a(2:)-a(1)+1.0_sp))) epsold=eps do kopt=2,KMAXX-1 if (a(kopt+1) > a(kopt)*alf(kopt-1,kopt)) exit end do kmax=kopt end if h=htry ysav(:)=y(:) if (h /= hnext .or. x /= xnew) then first=.true. kopt=kmax end if reduct=.false. main_loop: do do k=1,kmax xnew=x+h if (xnew == x) call nrerror('step size underflow in bsstep') call mmid(ysav,dydx,x,h,nseq(k),yseq,derivs) xest=(h/nseq(k))**2 call pzextr(k,xest,yseq,y,yerr) if (k /= 1) then errmax=maxval(abs(yerr(:)/yscal(:))) errmax=max(TINY,errmax)/eps km=k-1 err(km)=(errmax/SAFE1)**(1.0_sp/(2*km+1)) end if if (k /= 1 .and. (k >= kopt-1 .or. first)) then if (errmax < 1.0) exit main_loop if (k == kmax .or. k == kopt+1) then red=SAFE2/err(km) exit else if (k == kopt) then if (alf(kopt-1,kopt) < err(km)) then red=1.0_sp/err(km) exit end if else if (kopt == kmax) then if (alf(km,kmax-1) < err(km)) then red=alf(km,kmax-1)*SAFE2/err(km) exit end if else if (alf(km,kopt) < err(km)) then red=alf(km,kopt-1)/err(km) exit end if end if end do red=max(min(red,REDMIN),REDMAX) h=h*red reduct=.true. end do main_loop x=xnew hdid=h first=.false. kopt=1+iminloc(a(2:km+1)*max(err(1:km),SCALMX)) scale=max(err(kopt-1),SCALMX) wrkmin=scale*a(kopt) hnext=h/scale if (kopt >= k .and. kopt /= kmax .and. .not. reduct) then fact=max(scale/alf(kopt-1,kopt),SCALMX) if (a(kopt+1)*fact <= wrkmin) then hnext=h/fact kopt=kopt+1 end if end if END SUBROUTINE bsstep FUNCTION hypgeo(a,b,c,z) USE nrtype USE hypgeo_info USE nr, ONLY : bsstep,hypdrv,hypser,odeint IMPLICIT NONE COMPLEX(SPC), INTENT(IN) :: a,b,c,z COMPLEX(SPC) :: hypgeo REAL(SP), PARAMETER :: EPS=1.0e-6_sp COMPLEX(SPC), DIMENSION(2) :: y REAL(SP), DIMENSION(4) :: ry if (real(z)**2+aimag(z)**2 <= 0.25) then call hypser(a,b,c,z,hypgeo,y(2)) RETURN else if (real(z) < 0.0) then hypgeo_z0=cmplx(-0.5_sp,0.0_sp,kind=spc) else if (real(z) <= 1.0) then hypgeo_z0=cmplx(0.5_sp,0.0_sp,kind=spc) else hypgeo_z0=cmplx(0.0_sp,sign(0.5_sp,aimag(z)),kind=spc) end if hypgeo_aa=a hypgeo_bb=b hypgeo_cc=c hypgeo_dz=z-hypgeo_z0 call hypser(hypgeo_aa,hypgeo_bb,hypgeo_cc,hypgeo_z0,y(1),y(2)) ry(1:4:2)=real(y) ry(2:4:2)=aimag(y) ! call odeint(ry,0.0_sp,1.0_sp,EPS,0.1_sp,0.0001_sp,hypdrv,bsstep) call odeint(ry,0.0_sp,1.0_sp,EPS,0.1_sp,0.000001_sp,hypdrv,bsstep) !!! FB y=cmplx(ry(1:4:2),ry(2:4:2),kind=spc) hypgeo=y(1) END FUNCTION hypgeo SUBROUTINE hypdrv(s,ry,rdyds) USE nrtype USE hypgeo_info IMPLICIT NONE REAL(SP), INTENT(IN) :: s REAL(SP), DIMENSION(:), INTENT(IN) :: ry REAL(SP), DIMENSION(:), INTENT(OUT) :: rdyds COMPLEX(SPC), DIMENSION(2) :: y,dyds COMPLEX(SPC) :: z y=cmplx(ry(1:4:2),ry(2:4:2),kind=spc) z=hypgeo_z0+s*hypgeo_dz dyds(1)=y(2)*hypgeo_dz dyds(2)=((hypgeo_aa*hypgeo_bb)*y(1)-(hypgeo_cc-& ((hypgeo_aa+hypgeo_bb)+1.0_sp)*z)*y(2))*hypgeo_dz/(z*(1.0_sp-z)) rdyds(1:4:2)=real(dyds) rdyds(2:4:2)=aimag(dyds) END SUBROUTINE hypdrv SUBROUTINE hypser(a,b,c,z,series,deriv) USE nrtype; USE nrutil, ONLY : nrerror IMPLICIT NONE COMPLEX(SPC), INTENT(IN) :: a,b,c,z COMPLEX(SPC), INTENT(OUT) :: series,deriv INTEGER(I4B) :: n INTEGER(I4B), PARAMETER :: MAXIT=1000 COMPLEX(SPC) :: aa,bb,cc,fac,temp deriv=cmplx(0.0_sp,0.0_sp,kind=spc) fac=cmplx(1.0_sp,0.0_sp,kind=spc) temp=fac aa=a bb=b cc=c do n=1,MAXIT fac=((aa*bb)/cc)*fac deriv=deriv+fac fac=fac*z/n series=temp+fac if (series == temp) RETURN temp=series aa=aa+1.0 bb=bb+1.0 cc=cc+1.0 end do call nrerror('hypser: convergence failure') END SUBROUTINE hypser SUBROUTINE odeint(ystart,x1,x2,eps,h1,hmin,derivs,rkqs) USE nrtype; USE nrutil, ONLY : nrerror,reallocate USE ode_path IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(INOUT) :: ystart REAL(SP), INTENT(IN) :: x1,x2,eps,h1,hmin INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype IMPLICIT NONE REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs !BL SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype IMPLICIT NONE REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE rkqs END INTERFACE REAL(SP), PARAMETER :: TINY=1.0e-30_sp INTEGER(I4B), PARAMETER :: MAXSTP=10000 INTEGER(I4B) :: nstp REAL(SP) :: h,hdid,hnext,x,xsav REAL(SP), DIMENSION(size(ystart)) :: dydx,y,yscal x=x1 h=sign(h1,x2-x1) nok=0 nbad=0 kount=0 y(:)=ystart(:) nullify(xp,yp) if (save_steps) then xsav=x-2.0_sp*dxsav allocate(xp(256)) allocate(yp(size(ystart),size(xp))) end if do nstp=1,MAXSTP call derivs(x,y,dydx) yscal(:)=abs(y(:))+abs(h*dydx(:))+TINY if (save_steps .and. (abs(x-xsav) > abs(dxsav))) & call save_a_step if ((x+h-x2)*(x+h-x1) > 0.0) h=x2-x call rkqs(y,dydx,x,h,eps,yscal,hdid,hnext,derivs) if (hdid == h) then nok=nok+1 else nbad=nbad+1 end if if ((x-x2)*(x2-x1) >= 0.0) then ystart(:)=y(:) if (save_steps) call save_a_step RETURN end if if (abs(hnext) < hmin) then print *, "abs(hnext) = ", abs(hnext) print *, "hmin = ", hmin call nrerror('stepsize smaller than minimum in odeint') end if h=hnext end do call nrerror('too many steps in odeint') CONTAINS !BL SUBROUTINE save_a_step kount=kount+1 if (kount > size(xp)) then xp=>reallocate(xp,2*size(xp)) yp=>reallocate(yp,size(yp,1),size(xp)) end if xp(kount)=x yp(:,kount)=y(:) xsav=x END SUBROUTINE save_a_step END SUBROUTINE odeint FUNCTION gammln_s(xx) USE nrtype; USE nrutil, ONLY : arth,assert IMPLICIT NONE REAL(SP), INTENT(IN) :: xx REAL(SP) :: gammln_s REAL(DP) :: tmp,x REAL(DP) :: stp = 2.5066282746310005_dp REAL(DP), DIMENSION(6) :: coef = (/76.18009172947146_dp,& -86.50532032941677_dp,24.01409824083091_dp,& -1.231739572450155_dp,0.1208650973866179e-2_dp,& -0.5395239384953e-5_dp/) call assert(xx > 0.0, 'gammln_s arg') x=xx tmp=x+5.5_dp tmp=(x+0.5_dp)*log(tmp)-tmp gammln_s=tmp+log(stp*(1.000000000190015_dp+& sum(coef(:)/arth(x+1.0_dp,1.0_dp,size(coef))))/x) END FUNCTION gammln_s FUNCTION gammln_v(xx) USE nrtype; USE nrutil, ONLY: assert IMPLICIT NONE INTEGER(I4B) :: i REAL(SP), DIMENSION(:), INTENT(IN) :: xx REAL(SP), DIMENSION(size(xx)) :: gammln_v REAL(DP), DIMENSION(size(xx)) :: ser,tmp,x,y REAL(DP) :: stp = 2.5066282746310005_dp REAL(DP), DIMENSION(6) :: coef = (/76.18009172947146_dp,& -86.50532032941677_dp,24.01409824083091_dp,& -1.231739572450155_dp,0.1208650973866179e-2_dp,& -0.5395239384953e-5_dp/) if (size(xx) == 0) RETURN call assert(all(xx > 0.0), 'gammln_v arg') x=xx tmp=x+5.5_dp tmp=(x+0.5_dp)*log(tmp)-tmp ser=1.000000000190015_dp y=x do i=1,size(coef) y=y+1.0_dp ser=ser+coef(i)/y end do gammln_v=tmp+log(stp*ser/x) END FUNCTION gammln_v ! FUNCTION qgaus(func,a,b) ! USE nrtype ! REAL(SP), INTENT(IN) :: a,b ! REAL(SP) :: qgaus ! INTERFACE ! FUNCTION func(x) ! USE nrtype ! REAL(SP), DIMENSION(:), INTENT(IN) :: x ! REAL(SP), DIMENSION(size(x)) :: func ! END FUNCTION func ! END INTERFACE ! REAL(SP) :: xm,xr ! REAL(SP), DIMENSION(5) :: dx, w = (/ 0.2955242247_sp,0.2692667193_sp,& ! 0.2190863625_sp,0.1494513491_sp,0.0666713443_sp /),& ! x = (/ 0.1488743389_sp,0.4333953941_sp,0.6794095682_sp,& ! 0.8650633666_sp,0.9739065285_sp /) ! xm=0.5_sp*(b+a) ! xr=0.5_sp*(b-a) ! dx(:)=xr*x(:) ! qgaus=xr*sum(w(:)*(func(xm+dx)+func(xm-dx))) ! END FUNCTION qgaus FUNCTION locatenr(xx,x) USE nrtype IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(IN) :: xx REAL(SP), INTENT(IN) :: x INTEGER(I4B) :: locatenr INTEGER(I4B) :: n,jl,jm,ju LOGICAL :: ascnd n=size(xx) ascnd = (xx(n) >= xx(1)) jl=0 ju=n+1 do if (ju-jl <= 1) exit jm=(ju+jl)/2 if (ascnd .eqv. (x >= xx(jm))) then jl=jm else ju=jm end if end do if (x == xx(1)) then locatenr=1 else if (x == xx(n)) then locatenr=n-1 else locatenr=jl end if END FUNCTION locatenr SUBROUTINE tridag_ser(a,b,c,r,u) USE nrtype; USE nrutil, ONLY : assert_eq,nrerror IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r REAL(SP), DIMENSION(:), INTENT(OUT) :: u REAL(SP), DIMENSION(size(b)) :: gam INTEGER(I4B) :: n,j REAL(SP) :: bet n=assert_eq((/size(a)+1,size(b),size(c)+1,size(r),size(u)/),'tridag_ser') bet=b(1) if (bet == 0.0) call nrerror('tridag_ser: Error at code stage 1') u(1)=r(1)/bet do j=2,n gam(j)=c(j-1)/bet bet=b(j)-a(j-1)*gam(j) if (bet == 0.0) & call nrerror('tridag_ser: Error at code stage 2') u(j)=(r(j)-a(j-1)*u(j-1))/bet end do do j=n-1,1,-1 u(j)=u(j)-gam(j+1)*u(j+1) end do END SUBROUTINE tridag_ser RECURSIVE SUBROUTINE tridag_par(a,b,c,r,u) USE nrtype; USE nrutil, ONLY : assert_eq,nrerror USE nr, ONLY : tridag_ser IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r REAL(SP), DIMENSION(:), INTENT(OUT) :: u INTEGER(I4B), PARAMETER :: NPAR_TRIDAG=4 INTEGER(I4B) :: n,n2,nm,nx REAL(SP), DIMENSION(size(b)/2) :: y,q,piva REAL(SP), DIMENSION(size(b)/2-1) :: x,z REAL(SP), DIMENSION(size(a)/2) :: pivc n=assert_eq((/size(a)+1,size(b),size(c)+1,size(r),size(u)/),'tridag_par') if (n < NPAR_TRIDAG) then call tridag_ser(a,b,c,r,u) else if (maxval(abs(b(1:n))) == 0.0) & call nrerror('tridag_par: possible singular matrix') n2=size(y) nm=size(pivc) nx=size(x) piva = a(1:n-1:2)/b(1:n-1:2) pivc = c(2:n-1:2)/b(3:n:2) y(1:nm) = b(2:n-1:2)-piva(1:nm)*c(1:n-2:2)-pivc*a(2:n-1:2) q(1:nm) = r(2:n-1:2)-piva(1:nm)*r(1:n-2:2)-pivc*r(3:n:2) if (nm < n2) then y(n2) = b(n)-piva(n2)*c(n-1) q(n2) = r(n)-piva(n2)*r(n-1) end if x = -piva(2:n2)*a(2:n-2:2) z = -pivc(1:nx)*c(3:n-1:2) call tridag_par(x,y,z,q,u(2:n:2)) u(1) = (r(1)-c(1)*u(2))/b(1) u(3:n-1:2) = (r(3:n-1:2)-a(2:n-2:2)*u(2:n-2:2) & -c(3:n-1:2)*u(4:n:2))/b(3:n-1:2) if (nm == n2) u(n)=(r(n)-a(n-1)*u(n-1))/b(n) end if END SUBROUTINE tridag_par SUBROUTINE spline(x,y,yp1,ypn,y2) USE nrtype; USE nrutil, ONLY : assert_eq USE nr, ONLY : tridag IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), INTENT(IN) :: yp1,ypn REAL(SP), DIMENSION(:), INTENT(OUT) :: y2 INTEGER(I4B) :: n REAL(SP), DIMENSION(size(x)) :: a,b,c,r n=assert_eq(size(x),size(y),size(y2),'spline') c(1:n-1)=x(2:n)-x(1:n-1) r(1:n-1)=6.0_sp*((y(2:n)-y(1:n-1))/c(1:n-1)) r(2:n-1)=r(2:n-1)-r(1:n-2) a(2:n-1)=c(1:n-2) b(2:n-1)=2.0_sp*(c(2:n-1)+a(2:n-1)) b(1)=1.0 b(n)=1.0 if (yp1 > 0.99e30_sp) then r(1)=0.0 c(1)=0.0 else r(1)=(3.0_sp/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) c(1)=0.5 end if if (ypn > 0.99e30_sp) then r(n)=0.0 a(n)=0.0 else r(n)=(-3.0_sp/(x(n)-x(n-1)))*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn) a(n)=0.5 end if call tridag(a(2:n),b(1:n),c(1:n-1),r(1:n),y2(1:n)) END SUBROUTINE spline FUNCTION splint(xa,ya,y2a,x) USE nrtype; USE nrutil, ONLY : assert_eq,nrerror USE nr, ONLY: locatenr IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya,y2a REAL(SP), INTENT(IN) :: x REAL(SP) :: splint INTEGER(I4B) :: khi,klo,n REAL(SP) :: a,b,h n=assert_eq(size(xa),size(ya),size(y2a),'splint') klo=max(min(locatenr(xa,x),n-1),1) khi=klo+1 h=xa(khi)-xa(klo) if (h == 0.0) call nrerror('bad xa input in splint') a=(xa(khi)-x)/h b=(x-xa(klo))/h splint=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_sp END FUNCTION splint SUBROUTINE sort(arr) USE nrtype; USE nrutil, ONLY : swap,nrerror IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr INTEGER(I4B), PARAMETER :: NN=15, NSTACK=50 REAL(SP) :: a INTEGER(I4B) :: n,k,i,j,jstack,l,r INTEGER(I4B), DIMENSION(NSTACK) :: istack n=size(arr) jstack=0 l=1 r=n do if (r-l < NN) then do j=l+1,r a=arr(j) do i=j-1,l,-1 if (arr(i) <= a) exit arr(i+1)=arr(i) end do arr(i+1)=a end do if (jstack == 0) RETURN r=istack(jstack) l=istack(jstack-1) jstack=jstack-2 else k=(l+r)/2 call swap(arr(k),arr(l+1)) call swap(arr(l),arr(r),arr(l)>arr(r)) call swap(arr(l+1),arr(r),arr(l+1)>arr(r)) call swap(arr(l),arr(l+1),arr(l)>arr(l+1)) i=l+1 j=r a=arr(l+1) do do i=i+1 if (arr(i) >= a) exit end do do j=j-1 if (arr(j) <= a) exit end do if (j < i) exit call swap(arr(i),arr(j)) end do arr(l+1)=arr(j) arr(j)=a jstack=jstack+2 if (jstack > NSTACK) call nrerror('sort: NSTACK too small') if (r-i+1 >= j-l) then istack(jstack)=r istack(jstack-1)=i r=j-1 else istack(jstack)=j-1 istack(jstack-1)=l l=i end if end if end do END SUBROUTINE sort !!! Whizard wrapper for NR tools module nr_tools use kinds, only: default !NODEP! use nrtype, only: i4b, sp, spc !NODEP! use nr, only: gammln, hypgeo, locatenr, sort, spline, splint !NODEP! implicit none save private public :: nr_hypgeo, nr_gamma, nr_locate, nr_sort, nr_spline_t type :: nr_spline_t real(sp), dimension(:), allocatable :: xa, ya_re, ya_im, y2a_re, y2a_im contains procedure :: init => nr_spline_init procedure :: interpolate => nr_spline_interpolate procedure :: dealloc => nr_spline_dealloc end type nr_spline_t contains function nr_hypgeo (a, b, c, d) result (h) complex(default), intent(in) :: a, b, c, d complex(default) :: h complex(spc) :: a_sp, b_sp, c_sp, d_sp a_sp = cmplx(a,kind=sp) b_sp = cmplx(b,kind=sp) c_sp = cmplx(c,kind=sp) d_sp = cmplx(d,kind=sp) h = cmplx( hypgeo (a_sp, b_sp, c_sp, d_sp) , kind=default ) end function nr_hypgeo function nr_gamma (x) result (y) real(default), intent(in) :: x real(default) :: y y = real( exp(gammln(real(x,kind=sp))) , kind=default ) end function nr_gamma function nr_locate (xa, x) result (pos) real(default), dimension(:), intent(in) :: xa real(default), intent(in) :: x integer :: pos pos = locatenr (real(xa,kind=sp), real(x,kind=sp)) end function ! function nr_qgaus (fun, pts) result (res) ! real(default), dimension(:), intent(in) :: pts ! complex(default) :: res ! integer :: i_pts ! real(sp) :: lo, hi, re, im ! interface ! function fun (x) ! use kinds, only: default !NODEP! ! real(default), intent(in) :: x ! complex(default) :: fun ! end function fun ! end interface ! res = 0.0_default ! if ( size(pts) < 2 ) return ! do i_pts=1, size(pts)-1 ! lo = real(pts(i_pts ),kind=sp) ! hi = real(pts(i_pts+1),kind=sp) ! re = qgaus (fun_re, lo, hi) ! im = qgaus (fun_im, lo, hi) ! res = res + cmplx(re,im,kind=default) ! end do ! contains ! function fun_re (xa_sp) ! use kinds, only: default !NODEP! ! use nrtype, only: sp !NODEP! ! real(sp), dimension(:), intent(in) :: xa_sp ! real(sp), dimension(size(xa_sp)) :: fun_re ! real(default), dimension(size(xa_sp)) :: xa ! integer :: ix ! xa = real(xa_sp,kind=default) ! fun_re = (/ (real(fun(xa(ix)),kind=sp), ix=1, size(xa)) /) ! end function fun_re ! function fun_im (xa_sp) ! use kinds, only: default !NODEP! ! use nrtype, only: sp !NODEP! ! real(sp), dimension(:), intent(in) :: xa_sp ! real(sp), dimension(size(xa_sp)) :: fun_im ! real(default), dimension(size(xa_sp)) :: xa ! integer :: ix ! xa = real(xa_sp,kind=default) ! fun_im = (/ (real(aimag(fun(xa(ix))),kind=sp), ix=1, size(xa)) /) ! end function fun_im ! end function nr_qgaus subroutine nr_sort (array) real(default), dimension(:), intent(inout) :: array real(sp), dimension(size(array)) :: array_sp array_sp = real(array,kind=sp) call sort (array_sp) array = real(array_sp,kind=default) end subroutine nr_sort subroutine nr_spline_init (spl, xa_in, ya_in) class(nr_spline_t), intent(inout) :: spl real(default), dimension(:), intent(in) :: xa_in complex(default), dimension(:), intent(in) :: ya_in integer :: n if ( allocated(spl%xa) ) then print *, "ERROR: nr_spline: init: already initialized!" stop end if n = size(xa_in) allocate( spl%xa(n) ) allocate( spl%ya_re(n) ) allocate( spl%ya_im(n) ) allocate( spl%y2a_re(n) ) allocate( spl%y2a_im(n) ) spl%xa = real(xa_in,kind=sp) spl%ya_re = real(ya_in,kind=sp) spl%ya_im = real(aimag(ya_in),kind=sp) call spline (spl%xa, spl%ya_re, 1.e30, 1.e30, spl%y2a_re) call spline (spl%xa, spl%ya_im, 1.e30, 1.e30, spl%y2a_im) end subroutine nr_spline_init function nr_spline_interpolate (spl, x) result (y) complex(default) :: y class(nr_spline_t), intent(in) :: spl real(default), intent(in) :: x real(sp) :: y_re, y_im if ( .not.allocated(spl%xa) ) then print *, "ERROR: nr_spline: interpolate: not initialized!" stop end if y_re = splint (spl%xa, spl%ya_re, spl%y2a_re, real(x,kind=sp)) y_im = splint (spl%xa, spl%ya_im, spl%y2a_im, real(x,kind=sp)) y = cmplx(y_re,y_im,kind=default) end function nr_spline_interpolate subroutine nr_spline_dealloc (spl) class(nr_spline_t), intent(inout) :: spl if ( .not.allocated(spl%xa) ) then print *, "ERROR: nr_spline: dealloc: not initialized!" stop end if deallocate( spl%xa ) deallocate( spl%ya_re ) deallocate( spl%ya_im ) deallocate( spl%y2a_re ) deallocate( spl%y2a_im ) end subroutine nr_spline_dealloc end module nr_tools @ <<[[toppik.f]]>>= ! WHIZARD <> <> ! TOPPIK code by M. Jezabek, T. Teubner (v1.1, 1992), T. Teubner (1998) ! ! FB: -commented out numerical recipes code for hypergeometric 2F1 ! included in hypgeo.f90; ! -commented out unused function 'ZAPVQ1'; ! -replaced function 'cdabs' by 'abs'; ! -replaced function 'dimag' by 'aimag'; ! -replaced function 'dcmplx(,)' by 'cmplx(,,kind=kind(0d0))'; ! -replaced function 'dreal' by 'real'; ! -replaced function 'cdlog' by 'log'; ! -replaced PAUSE by PRINT statement to avoid compiler warning; ! -initialized 'idum' explicitly as real to avoid compiler warning. ! -modified 'adglg1', 'adglg2' and 'tttoppik' to catch unstable runs. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c ********************************************************************* c c Working version with all the different original potentials c like (p^2+q^2)/|p-q|^2, not transformed in terms of delta and 1/r^2; c accuracy eps=1.d-3 possible (only), but should be save, 13.8.'98, tt. c c ********************************************************************* c subroutine tttoppik(xenergy,xtm,xtg,xalphas,xscale,xcutn,xcutv, u xc0,xc1,xc2,xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2, u xkincm,xkinca,jknflg,jgcflg, u xkincv,jvflg,xim,xdi,np,xpp,xww,xdsdp,zvfct) c c ********************************************************************* c c !! THIS IS NOT A PUBLIC VERSION !! c c -- Calculation of the Green function in momentum space by solving the c Lippmann-Schwinger equation c G(p) = G_0(p) + G_0(p) int_0^xcutn V(p,q) G(q) dq c c -- Written by Thomas Teubner, Hamburg, November 1998 c * Based on TOPPIK Version 1.1 c from M. Jezabek and TT, Karlsruhe, June 1992 c * Version originally for non-constant top-width c * Constant width supplied here c * No generator included c c -- Use of double precision everywhere c c -- All masses, momenta, energies, widths in GeV c c -- Input parameters: c c xenergy : E=Sqrt[s]-2*topmass c xtm : topmass (in the Pole scheme) c xtg : top-width c xalphas : alpha_s^{MSbar,n_f=5}(xscale) c xscale : soft scale mu_{soft} c xcutn : numerical UV cutoff on all momenta c (UV cutoff of the Gauss-Legendre grid) c xcutv : renormalization cutoff on the c delta-, the (p^2+q^2)/(p-q)^2-, and the c 1/r^2-[1/|p-q|]-potential: c if (max(p,q).ge.xcutv) then the three potentials c are set to zero in the Lippmann-Schwinger equation c xc0 : 0th order coefficient for the Coulomb potential, c see calling example above c xc1 : 1st order coefficient for the Coulomb potential c xc2 : 2nd order coefficient for the Coulomb potential c xcdeltc : constant of the delta(r)- c [= constant in momentum space-] potential c xcdeltl : constant for the additional log(q^2/mu^2)-part of the c delta-potential: c xcdeltc*1 + xcdeltl*log(q^2/mu^2) c xcfullc : constant of the (p^2+q^2)/(p-q)^2-potential c xcfulll : constant for the additional log(q^2/mu^2)-part of the c (p^2+q^2)/(p-q)^2-potential c xcrm2 : constant of the 1/r^2-[1/|p-q|]-potential c xkincm : } kinetic corrections in the 0th order Green-function: c xkinca : } G_0(p):=1/[E+iGamma_t-p^2/m_t]*(1+xkincm)+xkinca c !!! WATCH THE SIGN IN G_0 !!! c jknflg : flag for these kinetic corrections: c 0 : no kinetic corrections applied c 1 : kinetic corrections applied with cutoff xcutv c for xkinca only c 2 : kinetic corrections applied with cutoff xcutv c for xkinca AND xkincm c jgcflg : flag for G_0(p) in the LS equation: c 0 (standard choice) : G_0(p) as given above c 1 (for TIPT) : G_0(p) = G_c^{0}(p) the 0th c order Coulomb-Green-function c in analytical form; not for c momenta p > 1000*topmass c xkincv : additional kinematic vertexcorrection in G_0, see below: c jvflg : flag for the additional vertexcorrection xkincv in the c ``zeroth order'' G_0(p) in the LS-equation: c 0 : no correction, means G = G_0 + G_0 int V G c with G_0=1/[E+iGamma_t-p^2/m_t]*(1+xkincm)+xkinca c 1 : apply the correction in the LS equation as c G = G_0 + xkincv*p^2/m_t^2/[E+iGamma_t-p^2/m_t] + c G_0 int V G c and correct the integral over Im[G(p)] to get sigma_tot c from the optical theorem by the same factor. c The cutoff xcutv is applied for these corrections. c c -- Output: c c xim : R_{ttbar} from the imaginary part of the green c function c xdi : R_{ttbar} form the integral over the momentum c distribution (no cutoff but the numerical one here!!) c np : number of points used for the grid; fixed in tttoppik c xpp : 1-dim array (max. 900 elements) giving the momenta of c the Gauss-Legendre grid (pp(i) in the code) c xww : 1-dim array (max. 900 elements) giving the corresponding c Gauss-Legendre weights for the grid c xdsdp : 1-dim array (max. 900 elements) giving the c momentum distribution of top: d\sigma/dp, c normalized to R, c at the momenta of the Gauss-Legendre grid xpp(i) c zvfct : 1-dim array (max. 900 elements) of COMPLEX*16 numbers c giving the vertex function K(p), G(p)=K(p)*G_0(p) c at the momenta of the grid c c ********************************************************************* c c implicit none real*8 u pi,energy,vzero,eps, u pp, u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u xx,critp,consde, u w1,w2,sig1,sig2,const, u gtpcor,etot, u xenergy,xtm,xtg,xalphas,xscale,xc0,xc1,xc2,xim,xdi, u xdsdp,xpp,xww, u cplas,scale,c0,c1,c2,cdeltc,cdeltl,cfullc,cfulll,crm2, u xcutn,dcut,xcutv, u xp,xpmax,hmass, u kincom,kincoa,kincov,xkincm,xkinca,xkincv, u xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2,chiggs complex*16 bb,gg,a1,a,g0,g0c,zvfct integer i,n,nmax,npot,np,gcflg,kinflg,jknflg,jgcflg, u jvflg,vflag parameter (nmax=900) dimension pp(nmax), bb(nmax), xx(nmax), gg(nmax), u w1(nmax), w2(nmax), a1(nmax), u xdsdp(nmax),xpp(nmax),xww(nmax),zvfct(nmax) c external a,gtpcor,g0,g0c c common/ovalco/ pi, energy, vzero, eps, npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/cplcns/cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs common/mom/ xp,xpmax,dcut common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag c pi=3.141592653589793238d0 c c Number of points to evaluate on the integral equation c (<=900 and n mod 3 = 0 !!): c n=66 n=600 np=n c c For second order potential with free parameters: c npot=5 c Internal accuracy for TOPPIK, the reachable limit may be smaller, c depending on the parameters. But increase in real accuracy only c in combination with large number of points. eps=1.d-3 c Some physical parameters: wgamma=2.07d0 zmass=91.187d0 wmass=80.33d0 bmass=4.7d0 c c Input: energy=xenergy tmass=xtm tgamma=xtg cplas=xalphas scale=xscale c0=xc0 c1=xc1 c2=xc2 cdeltc=xcdeltc cdeltl=xcdeltl cfullc=xcfullc cfulll=xcfulll crm2=xcrm2 kincom=xkincm kincoa=xkinca kincov=xkincv kinflg=jknflg gcflg=jgcflg vflag=jvflg c alphas=xalphas c c Cut for divergent potential-terms for large momenta in the function vhat c and in the integrals a(p): dcut=xcutv c c Numerical Cutoff of all momenta (maximal momenta of the grid): xpmax=xcutn if (dcut.gt.xpmax) then write(*,*) ' dcut > xpmax makes no sense! Stop.' stop endif c c Not needed for the fixed order potentials: alamb5=0.2d0 c c WRITE(*,*) 'INPUT TGAMMA=',TGAMMA c Needed in subroutine GAMMAT: GFERMI=1.16637d-5 c CALL GAMMAT c WRITE(*,*) 'CALCULATED TGAMMA=',TGAMMA c etot=2.d0*tmass+energy c if ((npot.eq.1).or.(npot.eq.3).or.(npot.eq.4).or. u (npot.eq.5)) then c For pure coulomb and fixed order potentials there is no delta-part: consde = 0.d0 else if (npot.eq.2) then c Initialize QCD-potential common-blocks and calculate constant multiplying c the delta-part of the 'qcutted' potential in momentum-space: call iniphc(1) call vqdelt(consde) else write (*,*) ' Potential not implemented! Stop.' stop endif c Delta-part of potential is absorbed by subtracting vzero from the c original energy (shift from the potential to the free Hamiltonian): vzero = consde / (2.d0*pi)**3 c write (*,*) 'vzero=', vzero c c Find x-values pp(i) and weigths w1(i) for the gaussian quadrature; c care about large number of points in the important intervals: c if (energy-vzero.le.0.d0) then cc call gauleg(0.d0, 1.d0, pp, w1, n/3) cc call gauleg(1.d0, 5.d0, pp(n/3+1), w1(n/3+1), n/3) cc call gauleg(0.d0, 0.2d0, pp(2*n/3+1), w1(2*n/3+1), n/3) c call gauleg(0.d0, 5.d0, pp, w1, n/3) c call gauleg(5.d0, 20.d0, pp(n/3+1), w1(n/3+1), n/3) c call gauleg(0.d0, 0.05d0, pp(2*n/3+1), w1(2*n/3+1), n/3) c else cc Avoid numerical singular points in the inner of the intervals: c critp = dsqrt((energy-vzero)*tmass) c if (critp.le.1.d0) then cc Gauss-Legendre is symmetric => automatically principal-value prescription: c call gauleg(0.d0, 2.d0*critp, pp, w1, n/3) c call gauleg(2.d0*critp, 20.d0, pp(n/3+1), c u w1(n/3+1), n/3) c call gauleg(0.d0, 0.05d0, pp(2*n/3+1), w1(2*n/3+1), n/3) c else cc Better behaviour at the border of the intervals: c call gauleg(0.d0, critp, pp, w1, n/3) c call gauleg(critp, 2.d0*critp, pp(n/3+1), c u w1(n/3+1), n/3) c call gauleg(0.d0, 1.d0/(2.d0*critp), pp(2*n/3+1), c u w1(2*n/3+1), n/3) c endif c endif c c Or different (simpler) method, good for V_JKT: if (energy.le.0.d0) then critp=tmass/3.d0 else critp=max(tmass/3.d0,2.d0*dsqrt(energy*tmass)) endif call gauleg(0.d0, critp, pp, w1, 2*n/3) call gauleg(1.d0/xpmax, 1.d0/critp, pp(2*n/3+1), u w1(2*n/3+1), n/3) c c Do substitution p => 1/p for the last interval explicitly: do 10 i=2*n/3+1,n pp(i) = 1.d0/pp(i) 10 continue c c Reorder the arrays for the third interval: do 20 i=1,n/3 xx(i) = pp(2*n/3+i) w2(i) = w1(2*n/3+i) 20 continue do 30 i=1,n/3 pp(n-i+1) = xx(i) w1(n-i+1) = w2(i) 30 continue c c Calculate the integrals a(p) for the given momenta pp(i) c and store weights and momenta for the output arrays: do 40 i=1,n a1(i) = a(pp(i)) !!! FB: can get stuck in original Toppik! !!! FB: abuse 'np' as a flag to communicate unstable runs if ( abs(a1(i)) .gt. 1d10 ) then np = -1 return endif xpp(i)=pp(i) xww(i)=w1(i) 40 continue do 41 i=n+1,nmax xpp(i)=0.d0 xww(i)=0.d0 41 continue c c Solve the integral-equation by solving a system of algebraic equations: call sae(pp, w1, bb, a1, n) c c (The substitution for the integration to infinity pp => 1/pp c is done already.) do 50 i=1,n zvfct(i)=bb(i) gg(i) = bb(i)*g0c(pp(i)) cc gg(i) = (1.d0 + bb(i))*g0c(pp(i)) cc Urspruenglich anderes (Minus) VZ hier, dafuer kein Minus mehr bei der cc Definition des WQs ueber Im G, 2.6.1998, tt. cc gg(i) = - (1.d0 + bb(i))*g0c(pp(i)) 50 continue c c Normalisation on R: const = 8.d0*pi/tmass**2 c c Proove of the optical theorem for the output values of sae: c Simply check if sig1 = sig2. sig1 = 0.d0 sig2 = 0.d0 do 60 i=1,n*2/3 c write(*,*) 'check! p(',i,') = ',pp(i) cvv if (pp(i).lt.dcut.and.vflag.eq.1) then sig1 = sig1 + w1(i)*pp(i)**2*aimag(gg(i) cc u *(1.d0+kincov*(pp(i)/tmass)**2) u *(1.d0+kincov*g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i))) u ) else sig1 = sig1 + w1(i)*pp(i)**2*aimag(gg(i)) endif if (pp(i).lt.dcut.and.kinflg.ne.0) then sig2 = sig2 + w1(i)*pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u *(1.d0-pp(i)**2/2.d0/tmass**2) cc u *tmass/dsqrt(tmass**2+pp(i)**2) xdsdp(i)=pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u *(1.d0-pp(i)**2/2.d0/tmass**2) u /(2.d0*pi**2)*const else sig2 = sig2 + w1(i)*pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) xdsdp(i)=pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u /(2.d0*pi**2)*const endif c write(*,*) 'xdsdp = ',xdsdp(i) c write(*,*) 'zvfct = ',zvfct(i) 60 continue c '*p**2' because of substitution p => 1/p in the integration of p**2*G(p) c to infinity do 70 i=n*2/3+1,n c write(*,*) 'check! p(',i,') = ',pp(i) cvv if (pp(i).lt.dcut.and.vflag.eq.1) then sig1 = sig1 + w1(i)*pp(i)**4*aimag(gg(i) cc u *(1.d0+kincov*(pp(i)/tmass)**2) u *(1.d0+kincov*g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i))) u ) else sig1 = sig1 + w1(i)*pp(i)**4*aimag(gg(i)) endif if (pp(i).lt.dcut.and.kinflg.ne.0) then sig2 = sig2 + w1(i)*pp(i)**4*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u *(1.d0-pp(i)**2/2.d0/tmass**2) cc u *tmass/dsqrt(tmass**2+pp(i)**2) xdsdp(i)=pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u *(1.d0-pp(i)**2/2.d0/tmass**2) u /(2.d0*pi**2)*const else sig2 = sig2 + w1(i)*pp(i)**4*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) xdsdp(i)=pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u /(2.d0*pi**2)*const endif c c write(*,*) 'xdsdp = ',xdsdp(i) c write(*,*) 'zvfct = ',zvfct(i) 70 continue do 71 i=n+1,nmax xdsdp(i)=0.d0 zvfct(i)=(0.d0,0.d0) 71 continue c c Normalisation on R: sig1 = sig1 / (2.d0*pi**2) * const sig2 = sig2 / (2.d0*pi**2) * const c c The results from the momentum space approach finally are: cc Jetzt Minus hier, 2.6.98, tt. xim=-sig1 xdi=sig2 c end c c complex*16 function g0(p) c implicit none real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi,energy,vzero,eps, u p,gtpcor,hmass integer npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot external gtpcor save g0=1.d0/cmplx(energy-vzero-p**2/tmass, u tgamma*gtpcor(p,2.d0*tmass+energy), u kind=kind(0d0)) end c complex*16 function g0c(p) c implicit none complex*16 hypgeo,green,zk,zi,amd2k,aa,bb,cc,zzp,zzm, u hypp,hypm,g0 real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi,energy,vzero,eps, u p,gtpcor,hmass, u kincom,kincoa,kincov,xp,xpmax,dcut integer npot,kinflg,gcflg,vflag COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag common/mom/ xp,xpmax,dcut external hypgeo,gtpcor,g0 save c if (gcflg.eq.0) then if (kinflg.eq.0) then g0c=g0(p) else if (kinflg.eq.1.and.p.lt.dcut) then g0c=g0(p)*(1.d0+kincom)+kincoa else if (kinflg.eq.1.and.p.ge.dcut) then g0c=g0(p)*(1.d0+kincom) else if (kinflg.eq.2.and.p.lt.dcut) then g0c=g0(p)*(1.d0+kincom)+kincoa else if (kinflg.eq.2.and.p.ge.dcut) then g0c=g0(p) else write(*,*) ' kinflg wrong! Stop.' stop endif else if (gcflg.eq.1) then zi=(0.d0,1.d0) zk=-tmass*cmplx(energy,tgamma u *gtpcor(p,2.d0*tmass+energy), u kind=kind(0d0)) zk=sqrt(zk) amd2k=4.d0/3.d0*alphas*tmass/2.d0/zk aa=(2.d0,0.d0) bb=(1.d0,0.d0) cc=2.d0-amd2k zzp=(1.d0+zi*p/zk)/2.d0 zzm=(1.d0-zi*p/zk)/2.d0 if (abs(zzp).gt.20.d0) then hypp=(1.d0-zzp)**(-aa)* u hypgeo(aa,cc-bb,cc,zzp/(zzp-1.d0)) else hypp=hypgeo(aa,bb,cc,zzp) endif if (abs(zzm).gt.20.d0) then hypm=(1.d0-zzm)**(-aa)* u hypgeo(aa,cc-bb,cc,zzm/(zzm-1.d0)) else hypm=hypgeo(aa,bb,cc,zzm) endif green=-zi*tmass/(4.d0*p*zk)/(1.d0-amd2k)*(hypp-hypm) c VZ anders herum als in Andres Konvention, da bei ihm G_0=1/[-E-i G+p^2/m]: g0c=-green if (p.gt.1.d3*tmass) then write(*,*) ' g0cana = ',g0c,' not reliable. Stop.' stop endif else write(*,*) ' gcflg wrong! Stop.' stop endif c end c c complex*16 function a(p) c implicit none real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy,ETOT,vzero, eps, $ QCUT,QMAT1,ALR,PCUT, u p, u xp,xpmax, xb1,xb2,dcut,ddcut, u a1, a2, a3, a4,a5,a6, u adglg1, fretil1, fretil2, fimtil1, fimtil2, u ALEFVQ, gtpcor, ad8gle, buf,adglg2, c u xerg, u kincom,kincoa,kincov,hmass ! complex*16 zapvq1,ZAPVGP complex*16 ZAPVGP !!! FB c u ,acomp integer npot,ILFLAG,kinflg,gcflg,vflag c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG common/ovalco/ pi, energy, vzero, eps, npot common/mom/ xp,xpmax,dcut common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag c external adglg1, fretil1, fretil2, fimtil1, fimtil2, ! u zapvq1, ALEFVQ, gtpcor,ZAPVGP,ad8gle,adglg2 u ALEFVQ, gtpcor,ZAPVGP,ad8gle,adglg2 !!! FB c if ((npot.eq.1).or.(npot.eq.3).or.(npot.eq.4).or. u (npot.eq.5)) then c xp=p buf=0.d0 c a1=0.d0 a2=0.d0 a3=0.d0 a4=0.d0 a5=0.d0 a6=0.d0 if (gcflg.eq.0) then ddcut=xpmax else if (gcflg.eq.1) then ddcut=dcut else write(*,*) ' gcflg wrong! Stop.' stop endif c if (2.d0*xp.lt.ddcut) then xb1=xp xb2=2.d0*xp c c More stable for logarithmically divergent fixed order potentials: c a1=adglg1(fretil1, buf, xb1, eps) !!! FB: can get stuck! a2=adglg1(fimtil1, buf, xb1, eps) c Slightly unstable: a3=adglg2(fretil1,xb1,xb2,eps) !!! FB: can get stuck! c No good: c a3=adglg1(fretil1,xb1,xb2,eps) c Not better: c call adqua(xb1,xb2,fretil1,xerg,eps) c a3=xerg c Also not better: c a1=adglg1(fretil1, buf, xb2, eps) c a4=adglg2(fimtil1,xb1,xb2,eps) c a5 = adglg2(fretil1, xb2, ddcut, eps) c a6 = adglg2(fimtil1, xb2, ddcut, eps) a5 = adglg2(fretil2, 1.d0/ddcut, 1.d0/xb2, eps) a6 = adglg2(fimtil2, 1.d0/ddcut, 1.d0/xb2, eps) else if (xp.lt.ddcut) then xb1=xp xb2=ddcut a1=adglg1(fretil1, buf, xb1, eps) a2=adglg1(fimtil1, buf, xb1, eps) a3=adglg2(fretil1,xb1,xb2,eps) a4=adglg2(fimtil1,xb1,xb2,eps) else if (ddcut.le.xp) then else write(*,*) ' Constellation not possible! Stop.' stop endif c a = 1.d0/(4.d0*pi**2)*cmplx(a1+a3+a5,a2+a4+a6, u kind=kind(0d0)) c else if (npot.eq.2) then PCUT=QCUT ETOT=ENERGY+2*TMASS a = ZAPVGP(P,ETOT,VZERO-ENERGY,PCUT,EPS) c acomp = zapvq1(ALEFVQ, p, vzero-energy, gtpcor, eps) c a = zapvq1(ALEFVQ, p, vzero-energy, gtpcor, eps) c acomp = acomp/a c if (abs(acomp-1.d0).gt.1.d-3) then c write (*,*) 'p=', p c write (*,*) 'acomp/a=', acomp c endif else write (*,*) ' Potential not implemented! Stop.' stop endif c end c real*8 function fretil1(xk) implicit none real*8 xk, freal external freal fretil1 = freal(xk) end c real*8 function fretil2(xk) implicit none real*8 xk, freal external freal fretil2 = freal(1.d0/xk) * xk**(-2) end c real*8 function fimtil1(xk) implicit none real*8 xk, fim external fim fimtil1 = fim(xk) end c real*8 function fimtil2(xk) implicit none real*8 xk, fim external fim fimtil2 = fim(1.d0/xk) * xk**(-2) end c real*8 function freal(xk) implicit none complex*16 vhat real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p,pmax, xk, gtpcor,dcut,hmass complex*16 g0,g0c integer npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/mom/ p,pmax,dcut external vhat, g0, g0c, gtpcor c freal = real(g0c(xk)*vhat(p, xk)) !!! FB: NaN? end c real*8 function fim(xk) implicit none complex*16 vhat real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p,pmax, xk, gtpcor,dcut,hmass complex*16 g0,g0c integer npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/mom/ p,pmax,dcut external vhat, g0, g0c, gtpcor fim = aimag(g0c(xk)*vhat(p, xk)) end c c complex*16 function vhat(p, xk) c implicit none complex*16 zi real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p, xk, u cnspot, phiint, phfqcd, AD8GLE, u pm, xkm, ALPHEF, u zeta3,cf,ca,tf,xnf,a1,a2,b0,b1, u cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2, u xkpln1st,xkpln2nd,xkpln3rd, u pp,pmax,dcut,hmass,chiggs integer npot parameter(zi=(0.d0,1.d0)) parameter(zeta3=1.20205690316d0, u cf=4.d0/3.d0,ca=3.d0,tf=1.d0/2.d0, u xnf=5.d0) c external AD8GLE, phfqcd, ALPHEF c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/pmaxkm/ pm, xkm common/mom/ pp,pmax,dcut common/cplcns/cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs c b0=11.d0-2.d0/3.d0*xnf b1=102.d0-38.d0/3.d0*xnf c a1=31.d0/9.d0*ca-20.d0/9.d0*tf*xnf a2=(4343.d0/162.d0+4.d0*pi**2-pi**4/4.d0+ u 22.d0/3.d0*zeta3)*ca**2- u (1798.d0/81.d0+56.d0/3.d0*zeta3)*ca*tf*xnf- u (55.d0/3.d0-16.d0*zeta3)*cf*tf*xnf+ u (20.d0/9.d0*tf*xnf)**2 c pm=p xkm=xk cnspot=-4.d0/3.d0*4.d0*pi c if (p/xk.le.1.d-5.and.p.le.1.d-5) then xkpln1st=2.d0 xkpln2nd=-4.d0*dlog(scale/xk) xkpln3rd=-6.d0*dlog(scale/xk)**2 else if (xk/p.le.1.d-5.and.xk.le.1.d-5) then xkpln1st=2.d0*(xk/p)**2 xkpln2nd=-4.d0*(xk/p)**2*dlog(scale/p) xkpln3rd=-6.d0*(xk/p)**2*dlog(scale/p)**2 else c xkpln1st=xk/p*dlog(dabs((p+xk)/(p-xk))) xkpln1st=xk/p*(dlog(p+xk)-dlog(dabs(p-xk))) xkpln2nd=xk/p*(-1.d0)*(dlog(scale/(p+xk))**2- u dlog(scale/dabs(p-xk))**2) xkpln3rd=xk/p*(-4.d0/3.d0)*(dlog(scale/(p+xk))**3- u dlog(scale/dabs(p-xk))**3) endif c if (npot.eq.2) then if (p/xk.le.1.d-5.and.p.le.1.d-5) then vhat = 2.d0 * cnspot * ALPHEF(xk) else if (xk/p.le.1.d-5.and.xk.le.1.d-5) then vhat = 2.d0 * cnspot * xk**2 / p**2 * ALPHEF(p) else phiint = cnspot * (AD8GLE(phfqcd, 0.d0, 0.3d0, 1.d-5) u +AD8GLE(phfqcd, 0.3d0, 1.d0, 1.d-5)) vhat = xk / p * dlog(dabs((p+xk)/(p-xk))) * phiint endif else if (npot.eq.1) then c0=1.d0 c1=0.d0 c2=0.d0 else if (npot.eq.3) then c0=1.d0+alphas/(4.d0*pi)*a1 c1=alphas/(4.d0*pi)*b0 c2=0 else if (npot.eq.4) then c0=1.d0+alphas/(4.d0*pi)*a1+(alphas/(4.d0*pi))**2*a2 c1=alphas/(4.d0*pi)*b0+ u (alphas/(4.d0*pi))**2*(b1+2.d0*b0*a1) c2=(alphas/(4.d0*pi))**2*b0**2 else if (npot.eq.5) then else write (*,*) ' Potential not implemented! Stop.' stop endif phiint=cnspot*alphas c c if ((xk+p).le.dcut) then c vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c u -1.d0/2.d0*(1.d0+2.d0*ca/cf) c u *(pi*cf*alphas)**2/tmass c u *xk/p*(p+xk-dabs(xk-p)) c else if (dabs(xk-p).lt.dcut) then c vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c u -1.d0/2.d0*(1.d0+2.d0*ca/cf) c u *(pi*cf*alphas)**2/tmass c u *xk/p*(dcut-dabs(xk-p)) c else if (dcut.le.dabs(xk-p)) then c vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c else c write(*,*) ' Not possible! Stop.' c stop c endif c if (max(xk,p).lt.dcut) then c Coulomb + first + second order corrections: vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c All other potentials: u +cdeltc*2.d0*xk**2 u +cdeltl*xk/p/2.d0*( u (p+xk)**2*(dlog(((p+xk)/scale)**2)-1.d0)- u (p-xk)**2*(dlog(((p-xk)/scale)**2)-1.d0)) u +cfullc*(p**2+xk**2)*xkpln1st u +cfulll*(p**2+xk**2)*xk/p/4.d0* u (dlog(((p+xk)/scale)**2)**2- u dlog(((p-xk)/scale)**2)**2) u +crm2*xk/p*(p+xk-dabs(xk-p)) else vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) endif endif c end c c c c --- Routines needed for use of phenomenological potentials --- c SUBROUTINE INIPHC(INIFLG) implicit real*8(a-h,o-z) save COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG CHARACTER QCTCHR,QMTCHR,ALFCHR DATA QCUT0/.100d0/,QMT1S/5.0d0/ c zmass= 91.187d0 if(INIFLG.eq.0) then c standard set of parameters ilflag= 1 alphas=.12d0 qcut= qcut0 qmat1= qmt1s else c Parameters of QCD potential specified by USER 5 write(*,*) 'QCD coupling at M_z: ALPHAS or LAMBDA ?' write(*,*) 'A/L :' read(*,895) ALFCHR if(ALFCHR.eq.'A'.or.ALFCHR.eq.'a') then ilflag= 1 write(*,*) 'alpha_s(M_z)= ?' read(*,*) alphas elseif(ALFCHR.eq.'L'.or.ALFCHR.eq.'l') then write(*,*) 'Lambda(nf=5) =?' read(*,*) alamb5 ilflag= 0 else write(*,*) '!!! PLEASE TYPE: A OR L !!!' goto 5 endif 10 write(*,896) qcut0 read(*,895) QCTCHR if(QCTCHR.eq.'Y'.or.QCTCHR.eq.'y') then qcut=qcut0 elseif(QCTCHR.eq.'N'.or.QCTCHR.eq.'n') then write(*,*) 'QCUT (GeV) = ?' read(*,*) qcut else write(*,*) '!!! PLEASE TYPE: Y OR N !!!' goto 10 endif 15 write(*,902) qmt1s read(*,895) QMTCHR if(QMTCHR.eq.'Y'.or.QMTCHR.eq.'y') then qmat1=qmt1s elseif(QMTCHR.eq.'N'.or.QMTCHR.eq.'n') then write(*,*) 'QMAT1 (GeV) = ?' read(*,*) qmat1 else write(*,*) '!!! PLEASE TYPE: Y OR N !!!' goto 15 endif endif 895 format(1A) 896 format(1x,'Long distance cut off for QCD potential'/ $ 1x,'QCUT = ',f5.4,' GeV. OK ? Y/N') 902 format(1x, $ 'Matching QCD for NF=5 and Richardson for NF=3 at QMAT1 =', $ f5.2,' GeV.'/1x,' OK ? Y/N') end c c real*8 function phfqcd(x) c integrand over k ? real*8 pm, xkm, x, ALPHEF external ALPHEF common/pmaxkm/ pm, xkm phfqcd = ALPHEF((pm+xkm)*(dabs(pm-xkm)/(pm+xkm))**x) end c c FUNCTION ALEFVQ(x) implicit real*8(a-h,o-z) external ALPHEF common/xtr101/ p0 data pi/3.1415926535897930d0/ q= p0*x ALEFVQ= - 4d0/3* 4*pi*ALPHEF(q) return end C C C C COMPLEX*16 FUNCTION ZAPVGP(P,ETOT,VME,PCUT,ACC) C C A(p,E)= ZAPVGP(P,ETOT,VME,PCUT,ACC) C for QCD potential VQQBAR(q) and GAMTPE(P,E) - momentum C dependent width of top quark in t-tbar system. C 2-dimensional integration C P - intrinsic momentum of t quark, ETOT - total energy of t-tbar, C VME=V0-E, where V0-potential at spatial infinity, E=ETOT-2*TMASS, C PCUT - cut off in momentum space; e.g. for QCD potential C given by ALPHEF PCUT=QCUT in COMMON/parflg/, C ACC - accuracy C external functions: VQQBAR,GAMTPE,ADQUA,AD8GLE,ADGLG1,ADGLG2 C IMPLICIT REAL*8(A-Z) EXTERNAL FIN01P,FIN02P,FIN03P,FIN04P,AD8GLE,ADGLG1,ADGLG2 COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass COMMON/XTR102/ P0,E0,VMEM,TM,ACC0 DATA PI/3.14159265/,BUF/1D-10/,SMALL/1D-2/ C For Testing only small = 1.d-1 C CONST= -TMASS/(8*PI**2*P) TM= TMASS ACC0=ACC*SMALL P0=P E0=ETOT VMEM=VME*TMASS IF(PCUT.LE.P) THEN XXRE=AD8GLE(FIN01P,BUF,PCUT,ACC)+ADGLG1(FIN01P,PCUT,P,ACC)+ $ ADGLG1(FIN02P,BUF,1/P,ACC) XXIM=AD8GLE(FIN03P,BUF,PCUT,ACC)+ADGLG1(FIN03P,PCUT,P,ACC)+ $ ADGLG1(FIN04P,BUF,1/P,ACC) ELSE XXRE=ADGLG1(FIN01P,BUF,P,ACC)+ADGLG2(FIN01P,P,PCUT,ACC)+ $ AD8GLE(FIN02P,BUF,1/PCUT,ACC) XXIM=ADGLG1(FIN03P,BUF,P,ACC)+ADGLG2(FIN03P,P,PCUT,ACC)+ $ AD8GLE(FIN04P,BUF,1/PCUT,ACC) ENDIF ZAPVGP=CONST*CMPLX(XXRE,XXIM,KIND=KIND(0d0)) END C REAL*8 FUNCTION FIN01P(Q) C this segment contains FIN01P,FIN02P,FIN03P,FIN04P IMPLICIT REAL*8(A-C,D-H,O-Z) EXTERNAL VQQBAR,FIN11P, FIN12P COMMON/XTR102/ P0,E0,VMEM,TM,ACC0 DATA PI/3.14159265/,BUF/1d-10/ Q0=Q XL=(P0-Q0)**2 XU=(P0+Q0)**2 CALL ADQUA(XL,XU,FIN11P,Y,ACC0) FIN01P= VQQBAR(Q0)*Q0*Y RETURN ENTRY FIN02P(Q) Q0=1/Q XL=(P0-Q0)**2 XU=(P0+Q0)**2 CALL ADQUA(XL,XU,FIN11P,Y,ACC0) FIN02P= VQQBAR(Q0)*Q0**3*Y RETURN ENTRY FIN03P(Q) Q0=Q XL=(P0-Q0)**2 XU=(P0+Q0)**2 CALL ADQUA(XL,XU,FIN12P,Y,ACC0) FIN03P= VQQBAR(Q0)*Q0*Y RETURN ENTRY FIN04P(Q) Q0=1/Q XL=(P0-Q0)**2 XU=(P0+Q0)**2 CALL ADQUA(XL,XU,FIN12P,Y,ACC0) FIN04P= VQQBAR(Q0)*Q0**3*Y END REAL*8 FUNCTION FIN11P(T) C this segment contains FIN11P,FIN12P IMPLICIT REAL*8(A-C,D-H,O-Z) EXTERNAL GAMTPE COMMON/XTR102/ P0,E0,VMEM,TM,ACC0 T1= T+VMEM TSQRT= SQRT(T) GAMMA= TM*GAMTPE(TSQRT,E0) FIN11P= T1/(T1**2+GAMMA**2) RETURN ENTRY FIN12P(T) T1= T+VMEM TSQRT= SQRT(T) GAMMA= TM*GAMTPE(TSQRT,E0) FIN12P= GAMMA/(T1**2+GAMMA**2) END C c SUBROUTINE VQDELT(VQ) c c evaluates constants multiplying Dirac delta in potentials VQCUT c calls: ADQUA c implicit real*8(a-h,o-z) external alphef,fncqct COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG data pi/3.141592653589793238D0/ c call adqua(1d-8,1d4,fncqct,y,1d-4) v=-4d0/3*2/pi*y VQ=(-.25-v)*(2*pi)**3 end c function fncqct(q) implicit real*8(a-h,o-z) fncqct=sin(q)/q*alphef(q) end c C REAL*8 FUNCTION VQQBAR(P) C C interquark potential for q- qbar singlet state C IMPLICIT REAL*8(A-C,D-H,O-Z) EXTERNAL ALPHEF COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass DATA PI/3.14159265/ VQQBAR = -4D0/3*4*PI*ALPHEF(P)/P**2 END C FUNCTION ALPHEF(q) c c V(q) = -4/3 * 4*pi*ALPHEF(q)/q**2 c input: alphas or alamb5 in COMMON/PHCONS/. If: c ILFLAG.EQ.0 alamb5= \Lambda_\{\bar MS}^{(5)} at M_z c ILFLAG.EQ.1 alphas = alpha_{strong} at M_z (91.161) c c effective coupling ALPHEF is defined as follows: c for q > qmat1=m_b: c alphas*( 1 +(31/3-10*nf/9)*alphas/(4*pi) ) c where alphas=\alpha_\bar{MS} for nf=5, i.e. c alpha=4*pi/( b0(nf=5)*x + b1(5)/b0(5)*ln(x) ) c and x = ln(q**2/alamb5**2) c for qmat1 > q > qcut: c 4*pi/b0(nefr=3)*(alfmt+1/log(1+q**2/alr**2)) c where alr=.4 GeV, nefr=3, and continuity --> alfmt c below qcut: alphrc*2*q**2/(q**2+qcut**2) (cont.-->alphrc) c implicit real*8(a-h,o-z) SAVE COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG common/parpot/ a5,b5,c5,alfmt,d,alphrc data pi/3.141592653589793238D0/, $ zold/-1d0/,qctold/-1d0/,alfold/-1d0/, $olmbd/-1d0/ c if(zmass.le.0d0 .or. qcut.le.0d0) STOP 10001 if(zold.ne.zmass .or. qcut.ne.qctold) num=0 if(ilflag.eq.0 .and. olmbd.ne.alamb5) num=0 if(ilflag.eq.1 .and. alfold.ne.alphas) num=0 if(num.eq.0)then num=num+1 zold=zmass qctold=qcut call potpar alfold= alphas olmbd= alamb5 endif if(q.le.qcut) then alphef=alphrc*(2*q**2)/(qcut**2+q**2) elseif(q.le.qmat1) then alphef=alfmt+d/log(1+q**2/alr**2) else x=2*log(q/alamb5) alfas5=1/(a5*x+b5*log(x)) alphef=alfas5*(1+c5*alfas5) endif end c c Only called by ALPHEF: SUBROUTINE POTPAR implicit real*8(a-h,o-z) COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG common/parpot/ a5,b5,c5,alfmt,d,alphrc data pi/3.141592653589793238D0/,nefr/3/ b0(nf)=11-2./3*nf b1(nf)=102-38./3*nf cn(nf)=31./3-10./9*nf alr=400d-3 a5=b0(5)/(4*pi) b5=b1(5)/b0(5)/(4*pi) c5=cn(5)/(4*pi) d=4*pi/b0(nefr) if(ilflag.eq.0) then if(alamb5.le.0d0) STOP 10002 xa=2*log(zmass/alamb5) alphas= 1/(a5*xa + b5*log(xa)) else if(alphas.le.0d0) STOP 10003 t0=0 t1=max(1d0,alphas*a5) 10 tm=(t0+t1)/2 fm=tm/alphas+b5*tm*log(tm)-a5 if(fm.lt.-1d-10) then t0=tm goto 10 elseif(fm.gt.1d-10) then t1=tm goto 10 endif alamb5=zmass*exp(-5d-1/tm) endif x=2*log(qmat1/alamb5) alfas=1/(a5*x+b5*log(x)) alfmt=alfas*(1+c5*alfas)-d/log(1+qmat1**2/alr**2) alphrc=alfmt+ d/log(1+qcut**2/alr**2) return end c c --- End of routines for phenomenological potentials --- c c c --- Routines for Gamma_top --- C SUBROUTINE GAMMAT C C on shell width of top quark including QCD corrections, c.f. C M.Jezabek and J.H. Kuhn, Nucl. Phys. B314(1989)1 C IMPLICIT REAL*8(A-C,D-H,O-Z) EXTERNAL DILOG COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass DATA PI/3.14159265/ F(X)= PI**2+2*DILOG(X)-2*DILOG(1-X)+( 4*X*(1-X-2*X**2)*LOG(X)+ $2*(1-X)**2*(5+4*X)*LOG(1-X) - (1-X)*(5+9*X-6*X**2) ) / $(2*(1-X)**2*(1+2*X)) Y= (WMASS/TMASS)**2 cc alpha_s(M_t) corresponding to alpha_s(M_Z)=0.118: cc alphas=0.107443d0 cc write(*,*) 'alphas=',alphas c Usage of alpha_s as given as input for the potential.. better use c alpha_s at a scale close to m_t.. TGAMMA= GFERMI*TMASS**3/(8*SQRT(2D0)*PI)*(1-Y)**2*(1+2*Y)* $(1- 2D0/3*ALPHAS/PI*F(Y)) END C C REAL*8 FUNCTION GAMTPE(P,ETOT) C C momentum dependent width of top quark in t-tbar system C GAMTPE = TGAMMA*GTPCOR(P,E), where TGAMMA includes C QCD corrections, see JKT, eq.(8), and C GTPCOR - correction factor for bound t quark C IMPLICIT REAL*8(A-C,D-H,O-Z) EXTERNAL GTPCOR COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass GAMTPE= TGAMMA*GTPCOR(P,ETOT) END C C C GTPCOR and GTPCOR1 should be merged (M.J.) !!!! c real*8 function gtpcor(topp,etot) real*8 topp,etot, u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI,hmass COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass c if (topp.ge.tmass/2.d0) then c gtpcor1=0.001d0 c else gtpcor=1.d0 c endif end c c c Correction function for non-constant (energy and momentum dependent) width: FUNCTION GTPCOR1(TOPP,ETOT) c c TOPP - momentum of t quark = - momentum of tbar c ETOT - total energy of t-tbar system c calls: GENWDS, RAN2 c c Evaluates a correction factor to the width of t-tbar system. c in future has to be replaced by a function evaluating c width including radiative corrections and GTPCOR. c I include two factors reducing the width: c a - time dilatation: for decay in flight lifetime c increased accordingly to relativistic kinematics c b - overall energy-momentum conservation: I assume that c t and tbar decay in flight and in this decays energies c of Ws follow from 2-body kinematics. Then I calculate c effective mass squared of b-bar system (it may be c negative!) from en-momentum conservation. c If effective mass is < 2*Mb + 2 GeV configuration c is rejected. The weight is acceptance. c IMPLICIT REAL*8(A-H,O-Z) real ran2 external ran2 PARAMETER(NG=20,NC=4) dimension gamma(0:NG),pw1(0:3),pw2(0:3),AIJ(NC,NC),BJ(NC), $AI(NC),SIG2IN(0:NG),XIK(0:NG,NC),INDX(NC) COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass SAVE NUM,EOLD,TOLD,AI data nevent/10000/, num/0/, eold/-1d5/, told/-1d0/ c C for test runs!! C nevent=1000 C if(etot.ne.eold) num=0 if(tmass.ne.told) num=0 5 if(num.eq.0) then c xdumm= ran2(-2) do 10 itp=0,NG tp=itp*tmass/NG*2 gamma(itp)=0 do 10 ix=1,nevent call GENWDS(tp,etot,pw1,pw2,efmsq) if(efmsq.gt.0d0) then efms=sqrt(efmsq) if(efms.ge. 2*bmass+2) gamma(itp)=gamma(itp)+1 endif 10 continue do 15 ix=0,NG 15 SIG2IN(IX)= MAX(1D0,GAMMA(IX)) DO 17 JX=1,NC IF(JX.EQ.1)THEN XIK(0,JX)= .5D0 ELSE XIK(0,JX)= 0D0 ENDIF DO 17 IX=1,NG tp= 2D0*ix/NG 17 XIK(IX,JX)= tp**(JX-1)/(1+EXP(tp*3)) DO 20 I=1,NC BJ(I)=0 DO 20 J=1,NC 20 AIJ(I,J)=0 DO 30 I=1,NC DO 25 IX=0,NG 25 BJ(I)= BJ(I)+GAMMA(IX)*XIK(IX,I)*SIG2IN(IX) DO 30 J=1,I DO 30 IX=0,NG 30 AIJ(I,J)= AIJ(I,J)+XIK(IX,I)*XIK(IX,J)*SIG2IN(IX) DO 35 I=1,NC DO 35 J=I,NC 35 AIJ(I,J)= AIJ(J,I) CALL LUDCMP(AIJ,NC,NC,INDX,D) CALL LUBKSB(AIJ,NC,NC,INDX,BJ) DO 40 I=1,NC 40 AI(I)= BJ(I)/NEVENT do 42 i=1,nc 42 write(*,*)'a(',i,')=',ai(i) do 100 ix=0,NG 100 gamma(ix)= gamma(ix)/nevent eold=etot told=tmass num= 1 endif SUM=AI(1) DO 110 I=2,NC 110 SUM= SUM+AI(I)*(TOPP/TMASS)**(I-1) C CORRF2= SUM/(1+ EXP(TOPP/TMASS*3)) CORRF2= SUM/(1+ EXP(MIN(1d1,TOPP/TMASS*3))) C if(topp.gt. 2d0*tmass) then C corrf1= 0.001d0 C else C ip= NG*topp/tmass/2 C corrf1= gamma(ip) C endif C write(*,*)'ratio=',corrf1/corrf2 C GTPCOR1 = CORRF2 GTPCOR1 = CORRF2*SQRT(1-TOPP**2/(TOPP**2+TMASS**2)) END c c Generator: only called by GTPCOR1 SUBROUTINE GENWDS(tp,etot,pw1,pw2,efm2) c c generates 4-momenta of W's and effective mass of b-bbar c from t and tbar quarks decays at flight (tp = momentum of t c = - momentum of tbar (in GeV) ) in Oz direction c implicit real*8(a-h,o-z) c real ran2 real ranf c external ran2 external ranf dimension pw1(0:3),pw2(0:3) save COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass data PI/3.141592653589793238D0/ real idum c 3 s1= wmass**2+wmass*wgamma*TAN((2*ran2(idum)-1)*pi/2) 3 s1= wmass**2+wmass*wgamma*TAN((2*ranf(idum)-1)*pi/2) if(s1.le.0d0) goto 3 wmass1= sqrt(s1) if(abs(wmass1-wmass).ge.3*wgamma) goto 3 c 4 s2= wmass**2+wmass*wgamma*TAN((2*ran2(idum)-1)*pi/2) 4 s2= wmass**2+wmass*wgamma*TAN((2*ranf(idum)-1)*pi/2) if(s2.le.0d0) goto 4 wmass2= sqrt(s2) if(abs(wmass2-wmass).ge.3*wgamma) goto 4 ew1= (tmass**2+wmass1**2-bmass**2)/(2*tmass) pwt1= sqrt(ew1**2-wmass1**2) ew2= (tmass**2+wmass2**2-bmass**2)/(2*tmass) pwt2= sqrt(ew2**2-wmass2**2) 5 p=tp c u1= 2*ran2(idum)-1 u1= 2*ranf(idum)-1 pw1z= pwt1*u1 c u2= 2*ran2(idum)-1 u2= 2*ranf(idum)-1 pw2z= pwt2*u2 et= sqrt(tmass**2+p**2) bet= p/et gam= et/tmass pw1(0)= gam*(ew1+bet*pw1z) pw1(3)= gam*(pw1z+bet*ew1) pw2(0)= gam*(ew2-bet*pw2z) pw2(3)= gam*(pw2z-bet*ew2) pw1tr= sqrt(pw1(0)**2-pw1(3)**2-wmass1**2) pw2tr= sqrt(pw2(0)**2-pw2(3)**2-wmass2**2) c phi1= 2*pi*ran2(idum) phi1= 2*pi*ranf(idum) c phi2= 2*pi*ran2(idum) phi2= 2*pi*ranf(idum) pw1(1)= pw1tr*cos(phi1) pw1(2)= pw1tr*sin(phi1) pw2(1)= pw2tr*cos(phi2) pw2(2)= pw2tr*sin(phi2) prec2= (pw1(1)+pw2(1))**2+(pw1(2)+pw2(2))**2+(pw1(3)+pw2(3))**2 erest=etot-pw1(0)-pw2(0) c efm2= erest*abs(erest)-prec2 END c c --- End of routines for Gamma_top --- c c --- Routines for solving linear equations and matrix inversion (complex) --- c subroutine sae(pp, w1, bb, a1, n) c implicit none complex*16 vhat real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u d, pp, w1, gtpcor,hmass, u xp,xpmax,dcut,kincom,kincoa,kincov complex*16 a, a1, bb, ff, cw, svw, g0, g0c integer i, j, npot, n, nmax, indx,kinflg,gcflg,vflag parameter (nmax=900) dimension bb(nmax), ff(nmax,nmax), pp(nmax), w1(nmax), u indx(nmax), cw(nmax), a1(nmax) c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/mom/ xp,xpmax,dcut common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag c external a, vhat, gtpcor, g0, g0c c do 10 i=1,n*2/3 cw(i) = w1(i) / (4.d0*pi**2) * g0c(pp(i)) c cw(i) = w1(i) / (4.d0*pi**2 * c u (cmplx(energy-vzero, tgamma* c u gtpcor(pp(i),2.d0*tmass+energy), c u kind=kind(0d0))-pp(i)**2/tmass)) 10 continue do 20 i=n*2/3+1,n cw(i) = w1(i) / (4.d0*pi**2) * g0c(pp(i)) * pp(i)**2 c cw(i) = w1(i) / (4.d0*pi**2 * c u (cmplx(energy-vzero, tgamma* c u gtpcor(pp(i),2.d0*tmass+energy), c u kind=kind(0d0)) / c u pp(i)**2 - 1.d0/tmass)) 20 continue c do 30 i=1,n cc bb(i) = a1(i) cvv if (pp(i).lt.dcut.and.vflag.eq.1) then c bb(i) = cmplx(1.d0+kincov*(pp(i)/tmass)**2,0.d0, c u kind=kind(0d0)) bb(i)=1.d0+kincov* u g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i)) else bb(i) = (1.d0,0.d0) endif svw = (0.d0,0.d0) do 40 j=1,n if (i.ne.j) then ff(i,j) = - vhat(pp(i),pp(j)) * cw(j) svw = svw + ff(i,j) endif 40 continue ff(i,i) = 1.d0 - a1(i) - svw 30 continue c call zldcmp(ff, n, nmax, indx, d) call zlbksb(ff, n, nmax, indx, bb) c end c c SUBROUTINE ZLBKSB(A,N,NP,INDX,B) C complex version of lubksb IMPLICIT NONE INTEGER I, II, INDX, J, LL, N, NP COMPLEX*16 A, B, SUM DIMENSION A(NP,NP),INDX(N),B(N) II=0 DO 12 I=1,N LL=INDX(I) SUM=B(LL) B(LL)=B(I) IF (II.NE.0)THEN DO 11 J=II,I-1 SUM=SUM-A(I,J)*B(J) 11 CONTINUE ELSE IF (SUM.NE.(0.D0,0.D0)) THEN II=I ENDIF B(I)=SUM 12 CONTINUE DO 14 I=N,1,-1 SUM=B(I) IF(I.LT.N)THEN DO 13 J=I+1,N SUM=SUM-A(I,J)*B(J) 13 CONTINUE ENDIF B(I)=SUM/A(I,I) 14 CONTINUE RETURN END c SUBROUTINE ZLDCMP(A,N,NP,INDX,D) C complex version of ludcmp IMPLICIT NONE INTEGER I, IMAX, INDX, J, K, N, NP, NMAX REAL*8 AAMAX, D, TINY, VV COMPLEX*16 A, DUM, SUM PARAMETER (NMAX=900) DIMENSION A(NP,NP), INDX(N), VV(NMAX) c tiny=1.d-5 c D=1.D0 DO 12 I=1,N AAMAX=0.D0 DO 11 J=1,N IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J)) 11 CONTINUE c IF (AAMAX.EQ.0.D0) PAUSE 'Singular matrix.' IF (AAMAX.EQ.0.D0) print *, "Singular matrix." VV(I)=1.D0/AAMAX 12 CONTINUE DO 19 J=1,N IF (J.GT.1) THEN DO 14 I=1,J-1 SUM=A(I,J) IF (I.GT.1)THEN DO 13 K=1,I-1 SUM=SUM-A(I,K)*A(K,J) 13 CONTINUE A(I,J)=SUM ENDIF 14 CONTINUE ENDIF AAMAX=0.D0 DO 16 I=J,N SUM=A(I,J) IF (J.GT.1)THEN DO 15 K=1,J-1 SUM=SUM-A(I,K)*A(K,J) 15 CONTINUE A(I,J)=SUM ENDIF DUM=VV(I)*ABS(SUM) IF (ABS(DUM).GE.AAMAX) THEN IMAX=I AAMAX=DUM ENDIF 16 CONTINUE IF (J.NE.IMAX) THEN DO 17 K=1,N DUM=A(IMAX,K) A(IMAX,K)=A(J,K) A(J,K)=DUM 17 CONTINUE D=-D VV(IMAX)=VV(J) ENDIF INDX(J)=IMAX IF (J.NE.N) THEN IF (A(J,J).EQ.(0.D0,0.D0)) A(J,J)=cmplx(TINY, 0.d0, u kind=kind(0d0)) DUM=1.D0/A(J,J) DO 18 I=J+1,N A(I,J)=A(I,J)*DUM 18 CONTINUE ENDIF 19 CONTINUE IF(A(N,N).EQ.(0.D0,0.D0)) A(N,N)=cmplx(TINY, 0.d0, u kind=kind(0d0)) RETURN END C C C *** TOOLS *** C C C ******* ROUTINES FOR GAUSSIAN INTEGRATIONS C C SUBROUTINE GAULEG(X1,X2,X,W,N) C C Given the lower and upper limits of integration X1 and X2 C and given N, this routine returns arrays X(N) and W(N) C containing the abscissas and weights of the Gauss-Legendre C N-point quadrature formula C IMPLICIT REAL*8 (A-H,O-Z) REAL*8 X1,X2,X(N),W(N) PARAMETER (EPS=3.D-14) save M=(N+1)/2 XM=0.5D0*(X2+X1) XL=0.5D0*(X2-X1) DO 12 I=1,M Z=DCOS(3.141592653589793238D0*(I-.25D0)/(N+.5D0)) 1 CONTINUE P1=1.D0 P2=0.D0 DO 11 J=1,N P3=P2 P2=P1 P1=((2.D0*J-1.D0)*Z*P2-(J-1.D0)*P3)/J 11 CONTINUE PP=N*(Z*P1-P2)/(Z*Z-1.D0) Z1=Z Z=Z1-P1/PP IF(DABS(Z-Z1).GT.EPS)GO TO 1 X(I)=XM-XL*Z X(N+1-I)=XM+XL*Z W(I)=2.D0*XL/((1.D0-Z*Z)*PP*PP) W(N+1-I)=W(I) 12 CONTINUE RETURN END C C DOUBLE PRECISION FUNCTION AD8GLE(F,A,B,EPS) implicit double precision (a-h,o-z) EXTERNAL F DIMENSION W(12),X(12) c SAVE W, X SAVE C C ****************************************************************** C C ADAPTIVE GAUSSIAN QUADRATURE. C C AD8GLE IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF C THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER C EPS. C C ****************************************************************** C DATA W / 0.10122 85362 90376 25915 25313 543D0, $ 0.22238 10344 53374 47054 43559 944D0, $ 0.31370 66458 77887 28733 79622 020D0, $ 0.36268 37833 78361 98296 51504 493D0, $ 0.27152 45941 17540 94851 78057 246D-1, $ 0.62253 52393 86478 92862 84383 699D-1, $ 0.95158 51168 24927 84809 92510 760D-1, $ 0.12462 89712 55533 87205 24762 822D0, $ 0.14959 59888 16576 73208 15017 305D0, $ 0.16915 65193 95002 53818 93120 790D0, $ 0.18260 34150 44923 58886 67636 680D0, $ 0.18945 06104 55068 49628 53967 232D0/ C DATA X / 0.96028 98564 97536 23168 35608 686D0, $ 0.79666 64774 13626 73959 15539 365D0, $ 0.52553 24099 16328 98581 77390 492D0, $ 0.18343 46424 95649 80493 94761 424D0, $ 0.98940 09349 91649 93259 61541 735D0, $ 0.94457 50230 73232 57607 79884 155D0, $ 0.86563 12023 87831 74388 04678 977D0, $ 0.75540 44083 55003 03389 51011 948D0, $ 0.61787 62444 02643 74844 66717 640D0, $ 0.45801 67776 57227 38634 24194 430D0, $ 0.28160 35507 79258 91323 04605 015D0, $ 0.95012 50983 76374 40185 31933 543D-1/ C C ****************************************************************** C GAUSS=0.0D0 AD8GLE=GAUSS IF(B.EQ.A) RETURN CONST=EPS/(B-A) BB=A C C COMPUTATIONAL LOOP. 1 AA=BB BB=B 2 C1=0.5D0*(BB+AA) C2=0.5D0*(BB-AA) S8=0.0D0 DO 3 I=1,4 U=C2*X(I) S8=S8+W(I)*(F(C1+U)+F(C1-U)) 3 CONTINUE S8=C2*S8 S16=0.0D0 DO 4 I=5,12 U=C2*X(I) S16=S16+W(I)*(F(C1+U)+F(C1-U)) 4 CONTINUE S16=C2*S16 IF( ABS(S16-S8) .LE. EPS*(abs(s8)+ABS(S16))*0.5D0 ) GO TO 5 BB=C1 IF( 1.D0+ABS(CONST*C2) .NE. 1.D0) GO TO 2 AD8GLE=0.0D0 write(*,*)'too high accuracy required in function ad8gle!' RETURN 5 GAUSS=GAUSS+S16 IF(BB.NE.B) GO TO 1 AD8GLE=GAUSS RETURN END C C DOUBLE PRECISION FUNCTION ADGLG1(F,A,B,EPS) IMPLICIT REAL*8 (A-H,O-Z) EXTERNAL F,AD8GLE,adqua DIMENSION W(6),X(6),xx(6) c SAVE W, XX, NUM SAVE C C ****************************************************************** C C ADAPTIVE GAUSSIAN QUADRATURE. C For x->b f(x) = O (ln^k (b-x) ) C A - lower limit, B - upper limit (integrable singularity) C AD8GLE IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF C THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER C EPS. C C ****************************************************************** DATA W / 4.58964 673950d-1, $ 4.17000 830772d-1, $ 1.13373 382074d-1, $ 1.03991 974531d-2, $ 2.61017 202815d-4, $ 8.98547 906430d-7/ C DATA X / 0.22284 66041 79d0, $ 1.18893 21016 73d0, $ 2.99273 63260 59d0, $ 5.77514 35691 05d0, $ 9.83746 74183 83d0, $ 15.98287 39806 02d0/ DATA NUM/0/ IF(NUM.eq.0d0) then do 1 ix=1,6 1 xx(ix)= EXP(-x(ix)) ENDIF num=num+1 sum=0d0 c=b-a sum6=0d0 do 10 in=1,6 10 sum6= sum6+ w(in)*f(b-c*xx(in)) sum6=sum6*c a1=a 15 a2= (a1+b)/2 c=b-a2 sumn=0d0 do 20 in=1,6 !!! FB: catch NaN if ( c/b .lt. 1d-9 ) then adglg1 = 1d15 return endif 20 sumn= sumn+ w(in)*f(b-c*xx(in)) !!! FB: f(b) = NaN ! sumn=sumn*c ctt c call adqua(a1,a2,f,sum1,eps) c sum1=sum1+sum sum1=AD8GLE(F,A1,A2,eps)+sum IF(ABS( (sum+sum6)/(sum1+sumn)-1d0 ).lt.EPS) THEN ctt c call adqua(a,a2,f,sum2,eps) sum2=AD8GLE(F,A,A2,eps) IF(ABS( (sum2+sumn)/(sum1+sumn)-1d0 ).gt.EPS) THEN sum=sum2 a1=a2 sum6=sumn goto 15 ENDIF ADGLG1= SUM1+SUMN RETURN ELSE sum=sum1 a1=a2 sum6=sumn goto 15 ENDIF END C DOUBLE PRECISION FUNCTION ADGLG2(F,A,B,EPS) IMPLICIT REAL*8 (A-H,O-Z) EXTERNAL F,AD8GLE DIMENSION W(6),X(6),xx(6) c SAVE W,XX,NUM SAVE C C ****************************************************************** C C ADAPTIVE GAUSSIAN QUADRATURE. C For x->A f(x) = O (ln^k (x-a) ) C A - lower limit (integrable singularity), B - upper limit C AD8GLE IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF C THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER C EPS. C C ****************************************************************** DATA W / 4.58964 673950d-1, $ 4.17000 830772d-1, $ 1.13373 382074d-1, $ 1.03991 974531d-2, $ 2.61017 202815d-4, $ 8.98547 906430d-7/ C DATA X / 0.22284 66041 79d0, $ 1.18893 21016 73d0, $ 2.99273 63260 59d0, $ 5.77514 35691 05d0, $ 9.83746 74183 83d0, $ 15.98287 39806 02d0/ DATA NUM/0/ IF(NUM.eq.0d0) then do 1 ix=1,6 1 xx(ix)= EXP(-x(ix)) ENDIF num=num+1 sum=0d0 c=b-a sum6=0d0 do 10 in=1,6 10 sum6= sum6+ w(in)*f(A+c*xx(in)) sum6=sum6*c b1=b 15 b2= (a+b1)/2 c=b2-a sumn=0d0 do 20 in=1,6 !!! FB: catch NaN if ( c/a .lt. 1d-9 ) then adglg2 = 1d15 return endif 20 sumn= sumn+ w(in)*f(a+c*xx(in)) !!! FB: f(a) = NaN ! sumn=sumn*c sum1=AD8GLE(F,b2,b1,eps)+sum IF(ABS( (sum+sum6)/(sum1+sumn)-1d0 ).lt.EPS) THEN sum2=AD8GLE(F,b2,b,eps) IF(ABS( (sum2+sumn)/(sum1+sumn)-1d0 ).gt.EPS) THEN sum=sum2 b1=b2 sum6=sumn goto 15 ENDIF ADGLG2= SUM1+SUMN RETURN ELSE sum=sum1 b1=b2 sum6=sumn goto 15 ENDIF END C C C------------------------------------------------------------------ C INTEGRATION ROUTINE ADQUA written by M. Jezabek ------ C------------------------------------------------------------------ C SUBROUTINE ADQUA(XL,XU,F,Y,ACC) C C ADAPTIVE GAUSS-LEGENDRE + SIMPSON'S RULE QUADRATURE C XL - LOWER LIMIT, XU - UPPER LIMIT, F - FUNCTION TO INTEGRATE C Y - INTEGRAL C ACC - ACCURACY (IF .LE. 0. ACC=1.D-6) c ****** new constants, 1 error removed, Oct '92 C C CALLS: SIMPSA C C PARAMETERS: NSUB > NO OF SUBDIVISION LEVELS IN GAUSS INTEGRATION C 100*2**IMAX > NO OF POINTS IN SIMPSON INTEGRATION C IMPLICIT REAL*8 (A-H,O-Z) EXTERNAL F DIMENSION VAL(25,2), BOUND(25,2,2), LEV(25),SING(25,3) DIMENSION W8(4),X8(4) DATA W8 $/0.101228536290376D0, 0.222381034453374D0, 0.313706645877887D0, $ 0.362683783378362D0/ DATA X8 $/0.960289856497536D0, 0.796666477413627D0, 0.525532409916329D0, $ 0.183434642495650D0/ save C IF(ACC.LE.0.D0) ACC=1.D-6 NSUB=24 NSG=25 NSC=0 A=XL B=XU C1=0.5d0*(A+B) C2=C1-A S8=0d0 DO 1 I=1,4 U=X8(I)*C2 1 S8=S8+W8(I)*(F(C1+U)+F(C1-U)) S8=S8*C2 XM=(XL+XU)/2.d0 BOUND(1,1,1)=XL BOUND(1,1,2)=XM BOUND(1,2,1)=XM BOUND(1,2,2)=XU NC=1 DO 3 IX=1,2 A=BOUND(NC,IX,1) B=BOUND(NC,IX,2) C1=0.5d0*(A+B) C2=C1-A VAL(NC,IX)=0.d0 DO 2 I=1,4 U=X8(I)*C2 2 VAL(NC,IX)=VAL(NC,IX)+W8(I)*(F(C1+U)+F(C1-U)) 3 VAL(NC,IX)=VAL(NC,IX)*C2 S16=VAL(NC,1)+VAL(NC,2) IF(DABS(S8-S16).GT.ACC*DABS(S16)) GOTO 4 Y=S16 RETURN 4 DO 5 I=1,NSUB 5 LEV(I)=0 NC1= NC+1 11 XM=(BOUND(NC,1,1)+BOUND(NC,1,2))/2.d0 BOUND(NC1,1,1)=BOUND(NC,1,1) BOUND(NC1,1,2)=XM BOUND(NC1,2,1)=XM BOUND(NC1,2,2)=BOUND(NC,1,2) DO 13 IX=1,2 A=BOUND(NC1,IX,1) B=BOUND(NC1,IX,2) C1=0.5d0*(A+B) C2=C1-A VAL(NC1,IX)=0.d0 DO 12 I=1,4 U=X8(I)*C2 12 VAL(NC1,IX)=VAL(NC1,IX)+W8(I)*(F(C1+U)+F(C1-U)) 13 VAL(NC1,IX)=VAL(NC1,IX)*C2 S16=VAL(NC1,1)+VAL(NC1,2) S8=VAL(NC,1) IF(DABS(S8-S16).LE.ACC*DABS(S16)) GOTO 20 NC=NC1 NC1= NC+1 IF(NC1.LE.NSUB) GOTO 11 C NC=NSUB USE SIMPSON'S RULE NSC=NSC+1 IF(NSC.LE.NSG) GOTO 15 WRITE(*,911) 911 FORMAT(1X,'ADQUA: TOO MANY SINGULARITIES') STOP 15 SING(NSC,1)=BOUND(NC,1,1) SING(NSC,2)=BOUND(NC,2,2) SING(NSC,3)=S16 S16=0.d0 NC=NC-1 20 VAL(NC,1)= S16 121 LEV(NC)=1 21 XM=(BOUND(NC,2,1)+BOUND(NC,2,2))/2.d0 BOUND(NC1,1,1)=BOUND(NC,2,1) BOUND(NC1,1,2)=XM BOUND(NC1,2,1)=XM BOUND(NC1,2,2)=BOUND(NC,2,2) DO 23 IX=1,2 A=BOUND(NC1,IX,1) B=BOUND(NC1,IX,2) C1=0.5d0*(A+B) C2=C1-A VAL(NC1,IX)=0.d0 DO 22 I=1,4 U=X8(I)*C2 22 VAL(NC1,IX)=VAL(NC1,IX)+W8(I)*(F(C1+U)+F(C1-U)) 23 VAL(NC1,IX)=VAL(NC1,IX)*C2 S16=VAL(NC1,1)+VAL(NC1,2) S8=VAL(NC,2) IF(DABS(S8-S16).LE.ACC*DABS(S16)) GOTO 40 NC=NC+1 NC1=NC+1 IF(NC1.LE.NSUB) GOTO 11 C NC=NSUB USE SIMPSON'S RULE NSC=NSC+1 IF(NSC.LE.NSG) GOTO 35 WRITE(*,911) STOP 35 SING(NSC,1)=BOUND(NC,1,1) SING(NSC,2)=BOUND(NC,2,2) SING(NSC,3)=S16 S16=0.d0 NC=NC-1 40 VAL(NC,2)= S16 45 IF(NC.GT.1) GOTO 50 Y1=VAL(1,1)+VAL(1,2) GOTO 100 50 NC0=NC-1 IF(LEV(NC0).EQ.0) IX=1 IF(LEV(NC0).EQ.1) IX=2 LEV(NC)=0 NC1=NC VAL(NC0,IX)=VAL(NC,1)+VAL(NC,2) NC=NC0 IF(IX.EQ.1) GOTO 121 GOTO 45 100 CONTINUE IF(NSC.GT.0) GOTO 101 Y=Y1 RETURN 101 FSUM=0.d0 DO 102 IK=1,NSC 102 FSUM=FSUM+DABS(SING(IK,3)) ACCR=ACC*DMAX1(FSUM,DABS(Y1))/FSUM/10.d0 DO 104 IK=1,NSC 104 CALL SIMPSA(SING(IK,1),SING(IK,2),F,SING(IK,3),ACCR) DO 106 IK=1,NSC 106 Y1=Y1+SING(IK,3) Y=Y1 RETURN END C SUBROUTINE SIMPSA(A,B,F,F0,ACC) C SIMPSON'S ADAPTIVE QUADRATURE IMPLICIT REAL*8 (A-H,O-Z) save EXTERNAL F IMAX=5 N0=100 H=(B-A)/N0 N02=N0/2 S2=0.d0 IC=1 S0=F(A)+F(B) DO 5 K=1,N02 5 S2=S2+F(A+2.d0*K*H) 7 S1=0.d0 DO 10 K=1,N02 10 S1=S1+F(A+(2.d0*K-1.d0)*H) Y=H/3.d0*(S0+4.d0*S1+2.d0*S2) IF(DABS(F0/Y-1.d0).GT.ACC) GOTO 20 RETURN 20 N02=N0 N0=2*N0 S2=S1+S2 H=H/2.d0 IF(IC.GT.IMAX) GOTO 30 F0=Y IC=IC+1 GOTO 7 30 ACC0=DABS(Y/F0-1.d0) WRITE(*,900) A,B,ACC0 STOP 900 FORMAT(1H ,'SIMPSA: TOO HIGH ACCURACY REQUIRED'/ /1X, 29HSINGULARITY IN THE INTERVAL ,D20.12,1X,D20.12/ /1X, 29HACCURACY ACHIEVED ,D20.12) END C C C ******* matrix-inversion-routines C SUBROUTINE LUDCMP(A,N,NP,INDX,D) IMPLICIT REAL*8(A-H,O-Z) PARAMETER (NMAX=100,TINY=1.0E-20) DIMENSION A(NP,NP),INDX(N),VV(NMAX) D=1. DO 12 I=1,N AAMAX=0. DO 11 J=1,N IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J)) 11 CONTINUE ! IF (AAMAX.EQ.0.) PAUSE 'Singular matrix.' IF (AAMAX.EQ.0.) print *, 'Singular matrix.' VV(I)=1./AAMAX 12 CONTINUE DO 19 J=1,N IF (J.GT.1) THEN DO 14 I=1,J-1 SUM=A(I,J) IF (I.GT.1)THEN DO 13 K=1,I-1 SUM=SUM-A(I,K)*A(K,J) 13 CONTINUE A(I,J)=SUM ENDIF 14 CONTINUE ENDIF AAMAX=0. DO 16 I=J,N SUM=A(I,J) IF (J.GT.1)THEN DO 15 K=1,J-1 SUM=SUM-A(I,K)*A(K,J) 15 CONTINUE A(I,J)=SUM ENDIF DUM=VV(I)*ABS(SUM) IF (DUM.GE.AAMAX) THEN IMAX=I AAMAX=DUM ENDIF 16 CONTINUE IF (J.NE.IMAX)THEN DO 17 K=1,N DUM=A(IMAX,K) A(IMAX,K)=A(J,K) A(J,K)=DUM 17 CONTINUE D=-D VV(IMAX)=VV(J) ENDIF INDX(J)=IMAX IF(J.NE.N)THEN IF(A(J,J).EQ.0.)A(J,J)=TINY DUM=1./A(J,J) DO 18 I=J+1,N A(I,J)=A(I,J)*DUM 18 CONTINUE ENDIF 19 CONTINUE IF(A(N,N).EQ.0.)A(N,N)=TINY RETURN END c SUBROUTINE LUBKSB(A,N,NP,INDX,B) IMPLICIT REAL*8(A-H,O-Z) DIMENSION A(NP,NP),INDX(N),B(N) II=0 DO 12 I=1,N LL=INDX(I) SUM=B(LL) B(LL)=B(I) IF (II.NE.0)THEN DO 11 J=II,I-1 SUM=SUM-A(I,J)*B(J) 11 CONTINUE ELSE IF (SUM.NE.0.) THEN II=I ENDIF B(I)=SUM 12 CONTINUE DO 14 I=N,1,-1 SUM=B(I) IF(I.LT.N)THEN DO 13 J=I+1,N SUM=SUM-A(I,J)*B(J) 13 CONTINUE ENDIF B(I)=SUM/A(I,I) 14 CONTINUE RETURN END C C C ******* RANDOM NUMBER GENERATORS C C FUNCTION RANF(DUMMY) C C RANDOM NUMBER FUNCTION TAKEN FROM KNUTH C (SEMINUMERICAL ALGORITHMS). C METHOD IS X(N)=MOD(X(N-55)-X(N-24),1/FMODUL) C NO PROVISION YET FOR CONTROL OVER THE SEED NUMBER. C C RANF GIVES ONE RANDOM NUMBER BETWEEN 0 AND 1. C IRN55 GENERATES 55 RANDOM NUMBERS BETWEEN 0 AND 1/FMODUL. C IN55 INITIALIZES THE 55 NUMBERS AND WARMS UP THE SEQUENCE. C PARAMETER (FMODUL=1.E-09) SAVE /CIRN55/ COMMON /CIRN55/NCALL,MCALL,IA(55) INTEGER IA CALL RANDAT IF( NCALL.EQ.0 ) THEN CALL IN55 ( IA,234612947 ) MCALL = 55 NCALL = 1 ENDIF IF ( MCALL.EQ.0 ) THEN CALL IRN55(IA) MCALL=55 ENDIF RANF=IA(MCALL)*FMODUL MCALL=MCALL-1 RETURN END C SUBROUTINE RANDAT C C INITIALISES THE NUMBER NCALL TO 0 TO FLAG THE FIRST CALL C OF THE RANDOM NUMBER GENERATOR C C SAVE /CIRN55/ C SAVE FIRST SAVE COMMON /CIRN55/NCALL,MCALL,IA(55) INTEGER IA LOGICAL FIRST DATA FIRST /.TRUE./ IF(FIRST)THEN FIRST=.FALSE. NCALL=0 ENDIF RETURN END C SUBROUTINE IN55(IA,IX) PARAMETER (MODULO=1000000000) INTEGER IA(55) C IA(55)=IX J=IX K=1 DO 10 I=1,54 II=MOD(21*I,55) IA(II)=K K=J-K IF(K.LT.0)K=K+MODULO J=IA(II) 10 CONTINUE DO 20 I=1,10 CALL IRN55(IA) 20 CONTINUE RETURN END C SUBROUTINE IRN55(IA) PARAMETER (MODULO=1000000000) INTEGER IA(55) DO 10 I=1,24 J=IA(I)-IA(I+31) IF(J.LT.0)J=J+MODULO IA(I)=J 10 CONTINUE DO 20 I=25,55 J=IA(I)-IA(I-24) IF(J.LT.0)J=J+MODULO IA(I)=J 20 CONTINUE RETURN END C C FUNCTION RAN2(IDUM) C ******************* REAL RDM(31) DATA IWARM/0/ C IF (IDUM.LT.0.OR.IWARM.EQ.0) THEN C INITIALIZATION OR REINITIALISATION IWARM=1 IA1= 1279 IC1= 351762 M1= 1664557 IA2= 2011 IC2= 221592 M2= 1048583 IA3= 15091 IC3= 6171 M3= 29201 IX1=MOD(-IDUM,M1) IX1=MOD(IA1*IX1+IC1,M1) IX2=MOD(IX1,M2) IX1=MOD(IA1*IX1+IC1,M1) IX3=MOD(IX1,M3) RM1=1./FLOAT(M1) RM2=1./FLOAT(M2) DO 10 J=1,31 IX1=MOD(IA1*IX1+IC1,M1) IX2=MOD(IA2*IX2+IC2,M2) 10 RDM(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1 ENDIF C C GENERATE NEXT NUMBER IN SEQUENCE IF(IWARM.EQ.0) GOTO 901 IX1=MOD(IA1*IX1+IC1,M1) IX2=MOD(IA2*IX2+IC2,M2) IX3=MOD(IA3*IX3+IC3,M3) J=1+(31*IX3)/M3 RAN2=RDM(J) RDM(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1 RETURN 901 PRINT 9010 9010 FORMAT(' RAN2: LACK OF ITINIALISATION') STOP END C C C ******* SPECIAL FUNCTIONS C C DOUBLE PRECISION FUNCTION DILOG(X) C C SPENCE'S DILOGARITHM IN DOUBLE PRECISION C IMPLICIT REAL*8 (A-H,O-Z) Z=-1.644934066848226 IF(X .LT.-1.0) GO TO 1 IF(X .LE. 0.5) GO TO 2 IF(X .EQ. 1.0) GO TO 3 IF(X .LE. 2.0) GO TO 4 Z=3.289868133696453 1 T=1.0/X S=-0.5 Z=Z-0.5*DLOG(DABS(X))**2 GO TO 5 2 T=X S=0.5 Z=0. GO TO 5 3 DILOG=1.644934066848226 RETURN 4 T=1.0-X S=-0.5 Z=1.644934066848226-DLOG(X)*DLOG(DABS(T)) 5 Y=2.666666666666667*T+0.666666666666667 B= 0.00000 00000 00001 A=Y*B +0.00000 00000 00004 B=Y*A-B+0.00000 00000 00011 A=Y*B-A+0.00000 00000 00037 B=Y*A-B+0.00000 00000 00121 A=Y*B-A+0.00000 00000 00398 B=Y*A-B+0.00000 00000 01312 A=Y*B-A+0.00000 00000 04342 B=Y*A-B+0.00000 00000 14437 A=Y*B-A+0.00000 00000 48274 B=Y*A-B+0.00000 00001 62421 A=Y*B-A+0.00000 00005 50291 B=Y*A-B+0.00000 00018 79117 A=Y*B-A+0.00000 00064 74338 B=Y*A-B+0.00000 00225 36705 A=Y*B-A+0.00000 00793 87055 B=Y*A-B+0.00000 02835 75385 A=Y*B-A+0.00000 10299 04264 B=Y*A-B+0.00000 38163 29463 A=Y*B-A+0.00001 44963 00557 B=Y*A-B+0.00005 68178 22718 A=Y*B-A+0.00023 20021 96094 B=Y*A-B+0.00100 16274 96164 A=Y*B-A+0.00468 63619 59447 B=Y*A-B+0.02487 93229 24228 A=Y*B-A+0.16607 30329 27855 A=Y*A-B+1.93506 43008 69969 DILOG=S*T*(A-B)+Z RETURN END c SUBROUTINE pzext0(iest,xest,yest,yz,dy,nv) implicit none INTEGER iest,nv,IMAX,NMAX REAL*8 xest,dy(nv),yest(nv),yz(nv) PARAMETER (IMAX=13,NMAX=50) INTEGER j,k1 REAL*8 delta,f1,f2,q,d(NMAX),qcol(NMAX,IMAX),x(IMAX) SAVE qcol,x x(iest)=xest do 11 j=1,nv dy(j)=yest(j) yz(j)=yest(j) 11 continue if(iest.eq.1) then do 12 j=1,nv qcol(j,1)=yest(j) 12 continue else do 13 j=1,nv d(j)=yest(j) 13 continue do 15 k1=1,iest-1 delta=1.d0/(x(iest-k1)-xest) f1=xest*delta f2=x(iest-k1)*delta do 14 j=1,nv q=qcol(j,k1) qcol(j,k1)=dy(j) delta=d(j)-q dy(j)=f1*delta d(j)=f2*delta yz(j)=yz(j)+dy(j) 14 continue 15 continue do 16 j=1,nv qcol(j,iest)=dy(j) 16 continue endif return END c c complex*16 function zdigamma(z) implicit none complex*16 z,psi,psipr1,psipr2 call mkpsi(z,psi,psipr1,psipr2) zdigamma=psi end c subroutine mkpsi(z,psi,psipr1,psipr2) implicit none complex*16 tmp,tmps2,tmps3,tmp0,tmp1,tmp2,ser0,ser1,ser2,ser3, . zz,z,psi,psipr1,psipr2,off0,off1,off2,zcf,ser02,ser12, . z1,z2 real*8 cof(6),re1 integer i data cof/76.18009173d0,-86.50532033d0,24.01409822d0, . -1.231739516d0,.120858003d-2,-.536382d-5/ save zz=z off0=cmplx(0.d0,0.d0,kind=kind(0d0)) off1=cmplx(0.d0,0.d0,kind=kind(0d0)) off2=cmplx(0.d0,0.d0,kind=kind(0d0)) 5 re1=real(zz) if (re1.le.0.d0) then off0=off0+1.d0/zz z1=zz*zz off1=off1-1.d0/z1 z2=z1*zz off2=off2+2.d0/z2 zz=zz+(1.d0,0.d0) goto 5 endif tmp=zz+cmplx(4.5d0,0.d0,kind=kind(0d0)) tmps2=tmp*tmp tmps3=tmp*tmps2 tmp0=(zz-cmplx(0.5d0,0.d0,kind=kind(0d0)))/tmp+log(tmp) u -cmplx(1.d0,0.d0,kind=kind(0d0)) tmp1=(5.d0,0.d0)/tmps2+1.d0/tmp tmp2=(-10.0d0,0.d0)/tmps3-1.d0/tmps2 ser0=cmplx(1.d0,0.d0,kind=kind(0d0)) ser1=cmplx(0.d0,0.d0,kind=kind(0d0)) ser2=cmplx(0.d0,0.d0,kind=kind(0d0)) ser3=cmplx(0.d0,0.d0,kind=kind(0d0)) do 10 i=1,6 zcf=cof(i)/zz ser0=ser0+zcf zcf=zcf/zz ser1=ser1+zcf zcf=zcf/zz ser2=ser2+zcf zcf=zcf/zz ser3=ser3+zcf zz=zz+(1.d0,0.d0) 10 continue ser1=-ser1 ser2=2.d0*ser2 ser3=-6.d0*ser3 ser02=ser0*ser0 ser12=ser1*ser1 psi=tmp0+ser1/ser0-off0 psipr1=tmp1+(ser2*ser0-ser12)/ser02-off1 psipr2=tmp2+(ser3*ser02-3.d0*ser2*ser1*ser0+2.d0*ser12*ser1) . /ser02/ser0-off2 return end @ <<[[toppik_axial.f]]>>= ! WHIZARD <> <> ! TOPPIK code by M. Jezabek, T. Teubner (v1.1, 1992), T. Teubner (1998) ! ! NOTE: axial part (p-wave) only ! ! FB: -commented out numerical recipes code for hypergeometric 2F1 ! included in hypgeo.f90; ! -replaced function 'cdabs' by 'abs'; ! -replaced function 'dabs' by 'abs'; ! -replaced function 'dimag' by 'aimag'; ! -replaced function 'dcmplx(,)' by 'cmplx(,,kind=kind(0d0))'; ! -replaced function 'dreal' by 'real'; ! -replaced function 'dlog' by 'log'; ! -replaced function 'dsqrt' by 'sqrt'; ! -renamed function 'a' to 'aax' ! -renamed function 'fretil1' to 'fretil1ax' ! -renamed function 'fretil2' to 'fretil2ax' ! -renamed function 'fimtil1' to 'fimtil1ax' ! -renamed function 'fimtil2' to 'fimtil2ax' ! -renamed function 'freal' to 'frealax' ! -renamed function 'fim' to 'fimax' ! -renamed subroutine 'vhat' to 'vhatax' ! -renamed subroutine 'sae' to 'saeax' ! -commented out many routines identically defined in 'toppik.f' ! -modified 'tttoppikaxial' to catch unstable runs. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c ************************************************************************ c Version tuned to provide O(1%) relative accuracy for Coulomb axial c vertex function at first and second order (search for `cctt'): c - integrals A(p), Vhat, Vhhat provided analytically w/out cut-off c - grid range fixed to 0.1 ... 10**6 absolut c - and grid size enhanced to 600 points (900 foreseen in arrays). c c This provides a compromise between stability and accuracy: c We need a relatively high momentum resolution and large maximal c momenta to achieve a ~1 percent accuracy, but the method of c direct inversion of the discretised integral equation for objects c whose integral is divergent induces instabilities at small c momenta. As the behaviour there is known, they can be cut off and c the vertex function fixed by hand; but limiting the grid c further would impact on the accuracy. c 22.3.2017, tt c ************************************************************************ c c Working version with all the different original potentials c like (p^2+q^2)/|p-q|^2, not transformed in terms of delta and 1/r^2; c accuracy eps=1.d-3 possible (only), but should be save, 13.8.'98, tt. c cleaned up a bit, 24.2.1999, tt. c c ********************************************************************* c c subroutine tttoppikaxial(xenergy,xtm,xtg,xalphas,xscale,xcutn, u xcutv, u xc0,xc1,xc2,xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2, u xkincm,xkinca,jknflg,jgcflg,xkincv,jvflg, u xim,xdi,np,xpp,xww,xdsdp,zftild) c c ********************************************************************* c c !! THIS IS NOT A PUBLIC VERSION !! c c !!! Only P wave result given as output!!! 9.4.1999, tt. c c -- Calculation of the Green function in momentum space by solving the c Lippmann-Schwinger equation c F(p) = G_0(p) + G_0(p) int_0^xcutn V(p,q) q.p/p^2 F(q) dq c c -- Written by Thomas Teubner, Hamburg, November 1998 c * Based on TOPPIK Version 1.1 c from M. Jezabek and TT, Karlsruhe, June 1992 c * Version originally for non-constant top-width c * Constant width supplied here c * No generator included c c -- Use of double precision everywhere c c -- All masses, momenta, energies, widths in GeV c c -- Input parameters: c c xenergy : E=Sqrt[s]-2*topmass c xtm : topmass (in the Pole scheme) c xtg : top-width c xalphas : alpha_s^{MSbar,n_f=5}(xscale) c xscale : soft scale mu_{soft} c xcutn : numerical UV cutoff on all momenta c (UV cutoff of the Gauss-Legendre grid) c xcutv : renormalization cutoff on the c delta-, the (p^2+q^2)/(p-q)^2-, and the c 1/r^2-[1/|p-q|]-potential: c if (max(p,q).ge.xcutv) then the three potentials c are set to zero in the Lippmann-Schwinger equation c xc0 : 0th order coefficient for the Coulomb potential, c see calling example above c xc1 : 1st order coefficient for the Coulomb potential c xc2 : 2nd order coefficient for the Coulomb potential c xcdeltc : constant of the delta(r)- c [= constant in momentum space-] potential c xcdeltl : constant for the additional log(q^2/mu^2)-part of the c delta-potential: c xcdeltc*1 + xcdeltl*log(q^2/mu^2) c xcfullc : constant of the (p^2+q^2)/(p-q)^2-potential c xcfulll : constant for the additional log(q^2/mu^2)-part of the c (p^2+q^2)/(p-q)^2-potential c xcrm2 : constant of the 1/r^2-[1/|p-q|]-potential c xkincm : } kinetic corrections in the 0th order Green function: c xkinca : } G_0(p):=1/[E+iGamma_t-p^2/m_t]*(1+xkincm)+xkinca c !!! WATCH THE SIGN IN G_0 !!! c jknflg : flag for these kinetic corrections: c 0 : no kinetic corrections applied c 1 : kinetic corrections applied with cutoff xcutv c for xkinca only c 2 : kinetic corrections applied with cutoff xcutv c for xkinca AND xkincm c jgcflg : flag for G_0(p) in the LS equation: c 0 (standard choice) : G_0(p) as given above c 1 (for TIPT) : G_0(p) = G_c^{0}(p) the 0th c order Coulomb Green function c in analytical form; not for c momenta p > 1000*topmass c xkincv : additional kinematic vertexcorrection in G_0, see below: c jvflg : flag for the additional vertexcorrection xkincv in the c ``zeroth order'' G_0(p) in the LS-equation: c 0 : no correction, means G = G_0 + G_0 int V G c with G_0=1/[E+iGamma_t-p^2/m_t]*(1+xkincm)+xkinca c 1 : apply the correction in the LS equation as c G = G_0 + xkincv*p^2/m_t^2/[E+iGamma_t-p^2/m_t] + c G_0 int V G c and correct the integral over Im[G(p)] to get sigma_tot c from the optical theorem by the same factor. c The cutoff xcutv is applied for these corrections. c c -- Output: c c xim : R^{P wave}_{ttbar} from the imaginary part of the Green c function c xdi : R^{P wave}_{ttbar} from the integral over the momentum c distribution: int_0^xcutv dp p^3/m_t*|F(p,E)|^2 c np : number of points used for the grid; fixed in tttoppik c xpp : 1-dim array (max. 900 elements) giving the momenta of c the Gauss-Legendre grid (pp(i) in the code) c xww : 1-dim array (max. 900 elements) giving the corresponding c Gauss-Legendre weights for the grid c xdsdp : 1-dim array (max. 900 elements) giving the c momentum distribution of top: d\sigma^{P wave}/dp, c normalized to R, c at the momenta of the Gauss-Legendre grid xpp(i) c zftild : 1-dim array (max. 900 elements) of COMPLEX*16 numbers c giving the vertex function K_A for the P-wave c at the momenta of the grid. c Then F(p)=K_A (p)*G_0(p) corresponding to G=K_V*G_0. c c ********************************************************************* c c implicit none real*8 u pi,energy,vzero,eps, u pp, u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI,hmass, u xx,critp,consde, u w1,w2,sig1,sig2,const, u gtpcor,etot, u xenergy,xtm,xtg,xalphas,xscale,xc0,xc1,xc2,xim,xdi, u xaai,xaad,xdsdp,xpp,xww, u cplas,scale,c0,c1,c2,cdeltc,cdeltl,cfullc,cfulll,crm2, u chiggs,xcutn,dcut,xcutv, u xp,xpmax, u kincom,kincoa,kincov,xkincm,xkinca,xkincv, u xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2 complex*16 bb,vec,gg,a1,aax,g0,g0c,zvfct,zftild integer i,n,nmax,npot,np,gcflg,kinflg,jknflg,jgcflg, u jvflg,vflag parameter (nmax=900) dimension pp(nmax),bb(nmax),vec(nmax),xx(nmax),gg(nmax), u w1(nmax),w2(nmax),a1(nmax), u xdsdp(nmax),xpp(nmax),xww(nmax), u zvfct(nmax),zftild(nmax) c external aax,gtpcor,g0,g0c c common/ovalco/ pi, energy, vzero, eps, npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/cplcns/cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs common/mom/ xp,xpmax,dcut common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag c pi=3.141592653589793238d0 c c Number of points to evaluate on the integral equation c (<=900 and n mod 3 = 0 !!): n=600 np=n c c For second order potential with free parameters: c npot=5 c Internal accuracy for TOPPIK, the reachable limit may be smaller, c depending on the parameters. But increase in real accuracy only c in combination with large number of points. eps=1.d-3 c Some physical parameters: wgamma=2.07d0 zmass=91.187d0 wmass=80.33d0 bmass=4.7d0 c c Input: tmass=xtm energy=xenergy tgamma=xtg cplas=xalphas scale=xscale c0=xc0 c1=xc1 c2=xc2 cdeltc=xcdeltc cdeltl=xcdeltl cfullc=xcfullc cfulll=xcfulll crm2=xcrm2 kincom=xkincm kincoa=xkinca kincov=xkincv kinflg=jknflg gcflg=jgcflg vflag=jvflg c alphas=xalphas c c Cut for divergent potential-terms for large momenta in the function vhatax c and in the integrals aax(p): dcut=xcutv c c Numerical Cutoff of all momenta (maximal momenta of the grid): xpmax=xcutn if (dcut.gt.xpmax) then write(*,*) ' dcut > xpmax makes no sense! Stop.' stop endif c c Not needed for the fixed order potentials: alamb5=0.2d0 c c WRITE(*,*) 'INPUT TGAMMA=',TGAMMA c Needed in subroutine GAMMAT: GFERMI=1.16637d-5 c CALL GAMMAT c WRITE(*,*) 'CALCULATED TGAMMA=',TGAMMA c etot=2.d0*tmass+energy c if ((npot.eq.1).or.(npot.eq.3).or.(npot.eq.4).or. u (npot.eq.5)) then c For pure coulomb and fixed order potentials there is no delta-part: consde = 0.d0 else if (npot.eq.2) then c Initialize QCD-potential common-blocks and calculate constant multiplying c the delta-part of the 'qcutted' potential in momentum-space: c call iniphc(1) c call vqdelt(consde) write(*,*) ' Not supplied with this version. Stop.' stop else write (*,*) ' Potential not implemented! Stop. 1' stop endif c Delta-part of potential is absorbed by subtracting vzero from the c original energy (shift from the potential to the free Hamiltonian): vzero = consde / (2.d0*pi)**3 c write (*,*) 'vzero=', vzero c c Find x-values pp(i) and weigths w1(i) for the gaussian quadrature; c care about large number of points in the important intervals: c if (energy-vzero.le.0.d0) then cc call gauleg(0.d0, 1.d0, pp, w1, n/3) cc call gauleg(1.d0, 5.d0, pp(n/3+1), w1(n/3+1), n/3) cc call gauleg(0.d0, 0.2d0, pp(2*n/3+1), w1(2*n/3+1), n/3) c call gauleg(0.d0, 5.d0, pp, w1, n/3) c call gauleg(5.d0, 20.d0, pp(n/3+1), w1(n/3+1), n/3) c call gauleg(0.d0, 0.05d0, pp(2*n/3+1), w1(2*n/3+1), n/3) c else cc Avoid numerical singular points in the inner of the intervals: c critp = sqrt((energy-vzero)*tmass) c if (critp.le.1.d0) then cc Gauss-Legendre is symmetric => automatically principal-value prescription: c call gauleg(0.d0, 2.d0*critp, pp, w1, n/3) c call gauleg(2.d0*critp, 20.d0, pp(n/3+1), c u w1(n/3+1), n/3) c call gauleg(0.d0, 0.05d0, pp(2*n/3+1), w1(2*n/3+1), n/3) c else cc Better behaviour at the border of the intervals: c call gauleg(0.d0, critp, pp, w1, n/3) c call gauleg(critp, 2.d0*critp, pp(n/3+1), c u w1(n/3+1), n/3) c call gauleg(0.d0, 1.d0/(2.d0*critp), pp(2*n/3+1), c u w1(2*n/3+1), n/3) c endif c endif c c Or different (simpler) method, good for V_JKT: if (energy.le.0.d0) then critp=tmass/3.d0 else critp=max(tmass/3.d0,2.d0*sqrt(energy*tmass)) endif c call gauleg(0.d0, critp, pp, w1, 2*n/3) c call gauleg(1.d0/xpmax, 1.d0/critp, pp(2*n/3+1), c u w1(2*n/3+1), n/3) cctt Tuned March 2017 for best possible numerical behaviour of P-wave call gauleg(0.1d0, 2.d0, pp, w1, 10) call gauleg(2.d0, critp, pp(11), w1(11), 2*n/3-10) call gauleg(1.d-6, 1.d0/critp, pp(2*n/3+1), u w1(2*n/3+1), n/3) c c Do substitution p => 1/p for the last interval explicitly: do 10 i=2*n/3+1,n pp(i) = 1.d0/pp(i) 10 continue c c Reorder the arrays for the third interval: do 20 i=1,n/3 xx(i) = pp(2*n/3+i) w2(i) = w1(2*n/3+i) 20 continue do 30 i=1,n/3 pp(n-i+1) = xx(i) w1(n-i+1) = w2(i) 30 continue c c Calculate the integrals aax(p) for the given momenta pp(i) c and store weights and momenta for the output arrays: do 40 i=1,n a1(i) = aax(pp(i)) !!! FB: can get stuck in original Toppik! !!! FB: abuse 'np' as a flag to communicate unstable runs if ( abs(a1(i)) .gt. 1d10 ) then np = -1 return endif xpp(i)=pp(i) xww(i)=w1(i) 40 continue do 41 i=n+1,nmax xpp(i)=0.d0 xww(i)=0.d0 41 continue c c Solve the integral-equation by solving a system of algebraic equations: call saeax(pp, w1, bb, vec, a1, n) c c (The substitution for the integration to infinity pp => 1/pp c is done already.) do 50 i=1,n zvfct(i)=bb(i) zftild(i)=vec(i) gg(i) = bb(i)*g0c(pp(i)) cc gg(i) = (1.d0 + bb(i))*g0c(pp(i)) cc Urspruenglich anderes (Minus) VZ hier, dafuer kein Minus mehr bei der cc Definition des WQs ueber Im G, 2.6.1998, tt. cc gg(i) = - (1.d0 + bb(i))*g0c(pp(i)) 50 continue c c Normalisation on R: const = 8.d0*pi/tmass**2 c c Proove of the optical theorem for the output values of saeax: c Simply check if sig1 = sig2. sig1 = 0.d0 sig2 = 0.d0 xaai = 0.d0 xaad = 0.d0 do 60 i=1,n*2/3 c write(*,*) 'check! p(',i,') = ',pp(i) cvv if (pp(i).lt.dcut.and.vflag.eq.1) then sig1 = sig1 + w1(i)*pp(i)**2*aimag(gg(i) cc u *(1.d0+kincov*(pp(i)/tmass)**2) u *(1.d0+kincov*g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i))) u ) else sig1 = sig1 + w1(i)*pp(i)**2*aimag(gg(i)) endif if (pp(i).lt.dcut.and.kinflg.ne.0) then sig2 = sig2 + w1(i)*pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u *(1.d0-pp(i)**2/2.d0/tmass**2) cc u *tmass/sqrt(tmass**2+pp(i)**2) c xdsdp(i)=pp(i)**2*abs(gg(i))**2 * c u tgamma*gtpcor(pp(i),etot) c u *(1.d0-pp(i)**2/2.d0/tmass**2) c u /(2.d0*pi**2)*const else sig2 = sig2 + w1(i)*pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) c xdsdp(i)=pp(i)**2*abs(gg(i))**2 * c u tgamma*gtpcor(pp(i),etot) c u /(2.d0*pi**2)*const endif xdsdp(i)=pp(i)**4/tmass**2*abs(zftild(i)*g0c(pp(i)))**2 u *tgamma*gtpcor(pp(i),etot) u /(2.d0*pi**2)*const xaai=xaai+w1(i)*pp(i)**4/tmass**2* u aimag(zftild(i)*g0c(pp(i))) xaad=xaad+w1(i)*pp(i)**4/tmass**2* u abs(zftild(i)*g0c(pp(i)))**2 * u tgamma*gtpcor(pp(i),etot) c write(*,*) 'xdsdp = ',xdsdp(i) c write(*,*) 'zvfct = ',zvfct(i) c write(*,*) 'zftild = ',zftild(i) 60 continue c '*p**2' because of substitution p => 1/p in the integration of p**2*G(p) c to infinity do 70 i=n*2/3+1,n c write(*,*) 'check! p(',i,') = ',pp(i) cvv if (pp(i).lt.dcut.and.vflag.eq.1) then sig1 = sig1 + w1(i)*pp(i)**4*aimag(gg(i) cc u *(1.d0+kincov*(pp(i)/tmass)**2) u *(1.d0+kincov*g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i))) u ) else sig1 = sig1 + w1(i)*pp(i)**4*aimag(gg(i)) endif if (pp(i).lt.dcut.and.kinflg.ne.0) then sig2 = sig2 + w1(i)*pp(i)**4*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u *(1.d0-pp(i)**2/2.d0/tmass**2) cc u *tmass/sqrt(tmass**2+pp(i)**2) c xdsdp(i)=pp(i)**2*abs(gg(i))**2 * c u tgamma*gtpcor(pp(i),etot) c u *(1.d0-pp(i)**2/2.d0/tmass**2) c u /(2.d0*pi**2)*const else sig2 = sig2 + w1(i)*pp(i)**4*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) c xdsdp(i)=pp(i)**2*abs(gg(i))**2 * c u tgamma*gtpcor(pp(i),etot) c u /(2.d0*pi**2)*const endif xdsdp(i)=pp(i)**4/tmass**2*abs(zftild(i)*g0c(pp(i)))**2 u *tgamma*gtpcor(pp(i),etot) u /(2.d0*pi**2)*const xaai=xaai+w1(i)*pp(i)**6/tmass**2* u aimag(zftild(i)*g0c(pp(i))) xaad=xaad+w1(i)*pp(i)**6/tmass**2* u abs(zftild(i)*g0c(pp(i)))**2 * u tgamma*gtpcor(pp(i),etot) c write(*,*) 'xdsdp = ',xdsdp(i) c write(*,*) 'zvfct = ',zvfct(i) c write(*,*) 'zftild = ',zftild(i) 70 continue do 71 i=n+1,nmax xdsdp(i)=0.d0 zvfct(i)=(0.d0,0.d0) zftild(i)=(0.d0,0.d0) 71 continue c c Normalisation on R: sig1 = sig1 / (2.d0*pi**2) * const sig2 = sig2 / (2.d0*pi**2) * const c c The results from the momentum space approach finally are: cc Jetzt Minus hier, 2.6.98, tt. c xim=-sig1 c xdi=sig2 xaai=-xaai / (2.d0*pi**2) * const xaad=xaad / (2.d0*pi**2) * const c Output of P wave part only: xim=xaai xdi=xaad c write(*,*) 'vvi = ',-sig1,' . vvd = ',sig2 c write(*,*) 'aai = ',xim,' . aad = ',xdi c end c c c c complex*16 function aax(p) c c Neue Funktion fuer die Integrale aax(p), die hier im Falle Cutoff -> infinity c fuer reine Coulombpotentiale vollstaendig analytisch loesbar sind. c 22.3.2001, tt. c implicit none complex*16 zi,zb,zlp,zlm,zalo,zanlo,zannlo,zahig,za real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI,hmass, u pi,energy,vzero,eps, u p,zeta3,cf,ca,tf,xnf,b0,b1,a1,a2,cnspot,phiint, u cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs integer npot parameter(zi=(0.d0,1.d0),zeta3=1.20205690316d0, u cf=4.d0/3.d0,ca=3.d0,tf=1.d0/2.d0,xnf=5.d0) c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/cplcns/cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs c b0=11.d0-2.d0/3.d0*xnf b1=102.d0-38.d0/3.d0*xnf c a1=31.d0/9.d0*ca-20.d0/9.d0*tf*xnf a2=(4343.d0/162.d0+4.d0*pi**2-pi**4/4.d0+ u 22.d0/3.d0*zeta3)*ca**2- u (1798.d0/81.d0+56.d0/3.d0*zeta3)*ca*tf*xnf- u (55.d0/3.d0-16.d0*zeta3)*cf*tf*xnf+ u (20.d0/9.d0*tf*xnf)**2 c cnspot=-4.d0/3.d0*4.d0*pi phiint=cnspot*alphas c zb=sqrt(tmass*cmplx(energy,tgamma,kind=kind(0d0))) zlp=log(zb+p) zlm=log(zb-p) c LO: no log in z-integral zalo=zi*pi/2.d0/p*(zlp-zlm) c from NL0: log in the z-integral zanlo=pi/2.d0/p*(zlp-zlm)*(pi+zi*(zlp+zlm)) c from NNLO: log**2 in the z-integral zannlo=pi/3.d0/p*(zlp-zlm) u *(3.d0*pi*(zlp+zlm)+2.d0*zi*(zlm**2+zlm*zlp+zlp**2)) c Sum of the Coulomb contributions: za=c0*zalo-c1*(zanlo-2.d0*dlog(scale)*zalo) u +c2*(zannlo-4.d0*dlog(scale)*zanlo u +4.d0*dlog(scale)**2*zalo) c (Higgs) Yukawa contribution cctt zahig=zi*pi/2.d0/p*log((zb+p+zi*hmass)/(zb-p+zi*hmass)) c Alltogether: cctt aax=-tmass/(4.d0*pi**2)*(phiint*za+chiggs*zahig) aax=-tmass/(4.d0*pi**2)*phiint*za c c write(*,*) 'aax(',p,')= ',aax end c real*8 function fretil1ax(xk) implicit none real*8 xk, frealax external frealax fretil1ax = frealax(xk) end c real*8 function fretil2ax(xk) implicit none real*8 xk, frealax external frealax fretil2ax = frealax(1.d0/xk) * xk**(-2) end c real*8 function fimtil1ax(xk) implicit none real*8 xk, fimax external fimax fimtil1ax = fimax(xk) end c real*8 function fimtil2ax(xk) implicit none real*8 xk, fimax external fimax fimtil2ax = fimax(1.d0/xk) * xk**(-2) end c real*8 function frealax(xk) implicit none complex*16 vhatax real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p,pmax, xk, gtpcor,dcut,hmass complex*16 g0,g0c integer npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/mom/ p,pmax,dcut external vhatax, g0, g0c, gtpcor c frealax = real(g0c(xk)*vhatax(p, xk)) end c real*8 function fimax(xk) implicit none complex*16 vhatax real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p,pmax, xk, gtpcor,dcut,hmass complex*16 g0,g0c integer npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/mom/ p,pmax,dcut external vhatax, g0, g0c, gtpcor fimax = aimag(g0c(xk)*vhatax(p, xk)) end c c complex*16 function vhatax(p, xk) c implicit none complex*16 zi real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p, xk, u cnspot, phiint, AD8GLE, u pm, xkm, c u phfqcd, ALPHEF, u zeta3,cf,ca,tf,xnf,a1,a2,b0,b1, u cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2, u xkpln1st,xkpln2nd,xkpln3rd, u pp,pmax,dcut,hmass,chiggs integer npot parameter(zi=(0.d0,1.d0)) parameter(zeta3=1.20205690316d0, u cf=4.d0/3.d0,ca=3.d0,tf=1.d0/2.d0, u xnf=5.d0) c external AD8GLE c u , phfqcd, ALPHEF c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/pmaxkm/ pm, xkm common/mom/ pp,pmax,dcut common/cplcns/cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs c b0=11.d0-2.d0/3.d0*xnf b1=102.d0-38.d0/3.d0*xnf c a1=31.d0/9.d0*ca-20.d0/9.d0*tf*xnf a2=(4343.d0/162.d0+4.d0*pi**2-pi**4/4.d0+ u 22.d0/3.d0*zeta3)*ca**2- u (1798.d0/81.d0+56.d0/3.d0*zeta3)*ca*tf*xnf- u (55.d0/3.d0-16.d0*zeta3)*cf*tf*xnf+ u (20.d0/9.d0*tf*xnf)**2 c pm=p xkm=xk cnspot=-4.d0/3.d0*4.d0*pi c if (p/xk.le.1.d-5.and.p.le.1.d-5) then xkpln1st=2.d0 xkpln2nd=-4.d0*log(scale/xk) xkpln3rd=-6.d0*log(scale/xk)**2 else if (xk/p.le.1.d-5.and.xk.le.1.d-5) then xkpln1st=2.d0*(xk/p)**2 xkpln2nd=-4.d0*(xk/p)**2*log(scale/p) xkpln3rd=-6.d0*(xk/p)**2*log(scale/p)**2 else c xkpln1st=xk/p*log(abs((p+xk)/(p-xk))) xkpln1st=xk/p*(log(p+xk)-log(abs(p-xk))) cctt sign checked again, 2.2.2017, tt. xkpln2nd=xk/p*(-1.d0)*(log(scale/(p+xk))**2- u log(scale/abs(p-xk))**2) xkpln3rd=xk/p*(-4.d0/3.d0)*(log(scale/(p+xk))**3- u log(scale/abs(p-xk))**3) endif c c if (npot.eq.2) then c if (p/xk.le.1.d-5.and.p.le.1.d-5) then c vhatax = 2.d0 * cnspot * ALPHEF(xk) c else if (xk/p.le.1.d-5.and.xk.le.1.d-5) then c vhatax = 2.d0 * cnspot * xk**2 / p**2 * ALPHEF(p) c else c phiint = cnspot * (AD8GLE(phfqcd, 0.d0, 0.3d0, 1.d-5) c u +AD8GLE(phfqcd, 0.3d0, 1.d0, 1.d-5)) c vhatax = xk / p * log(abs((p+xk)/(p-xk))) * phiint c endif c else if (npot.eq.1) then c0=1.d0 c1=0.d0 c2=0.d0 else if (npot.eq.3) then c0=1.d0+alphas/(4.d0*pi)*a1 c1=alphas/(4.d0*pi)*b0 c2=0 else if (npot.eq.4) then c0=1.d0+alphas/(4.d0*pi)*a1+(alphas/(4.d0*pi))**2*a2 c1=alphas/(4.d0*pi)*b0+ u (alphas/(4.d0*pi))**2*(b1+2.d0*b0*a1) c2=(alphas/(4.d0*pi))**2*b0**2 else if (npot.eq.5) then else write (*,*) ' Potential not implemented! Stop. 3' stop endif phiint=cnspot*alphas c c if ((xk+p).le.dcut) then c vhatax=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c u -1.d0/2.d0*(1.d0+2.d0*ca/cf) c u *(pi*cf*alphas)**2/tmass c u *xk/p*(p+xk-abs(xk-p)) c else if (abs(xk-p).lt.dcut) then c vhatax=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c u -1.d0/2.d0*(1.d0+2.d0*ca/cf) c u *(pi*cf*alphas)**2/tmass c u *xk/p*(dcut-abs(xk-p)) c else if (dcut.le.abs(xk-p)) then c vhatax=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c else c write(*,*) ' Not possible! Stop.' c stop c endif c c ctt c Cut not applied here, should be left hard-wired in gauleg for stability of axial part. March 2017, tt. c if (max(xk,p).lt.dcut) then c Coulomb + first + second order corrections: vhatax=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c All other potentials: c u +cdeltc*2.d0*xk**2 c u +cdeltl*xk/p/2.d0*( c u (p+xk)**2*(log(((p+xk)/scale)**2)-1.d0)- c u (p-xk)**2*(log(((p-xk)/scale)**2)-1.d0)) c u +cfullc*(p**2+xk**2)*xkpln1st c u +cfulll*(p**2+xk**2)*xk/p/4.d0* c u (log(((p+xk)/scale)**2)**2- c u log(((p-xk)/scale)**2)**2) c u +crm2*xk/p*(p+xk-abs(xk-p)) c else c vhatax=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c endif c endif c end c c complex*16 function vhhat(p, xk) c implicit none complex*16 zi real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p, xk, u cnspot, phiint, AD8GLE, u pm, xkm, u zeta3,cf,ca,tf,xnf,a1,a2,b0,b1, u cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2, u xkpln1st,xkpln2nd, u pp,pmax,dcut,hmass,chiggs integer npot parameter(zi=(0.d0,1.d0)) parameter(zeta3=1.20205690316d0, u cf=4.d0/3.d0,ca=3.d0,tf=1.d0/2.d0, u xnf=5.d0) c external AD8GLE c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/pmaxkm/ pm, xkm common/mom/ pp,pmax,dcut common/cplcns/cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs c b0=11.d0-2.d0/3.d0*xnf b1=102.d0-38.d0/3.d0*xnf c a1=31.d0/9.d0*ca-20.d0/9.d0*tf*xnf a2=(4343.d0/162.d0+4.d0*pi**2-pi**4/4.d0+ u 22.d0/3.d0*zeta3)*ca**2- u (1798.d0/81.d0+56.d0/3.d0*zeta3)*ca*tf*xnf- u (55.d0/3.d0-16.d0*zeta3)*cf*tf*xnf+ u (20.d0/9.d0*tf*xnf)**2 c pm=p xkm=xk cnspot=-4.d0/3.d0*4.d0*pi c if (npot.eq.1) then c0=1.d0 c1=0.d0 c2=0.d0 else if (npot.eq.3) then c0=1.d0+alphas/(4.d0*pi)*a1 c1=alphas/(4.d0*pi)*b0 c2=0 else if (npot.eq.4) then write(*,*) '2nd order Coulomb in Vhhat not implemented yet.' stop c0=1.d0+alphas/(4.d0*pi)*a1+(alphas/(4.d0*pi))**2*a2 c1=alphas/(4.d0*pi)*b0+ u (alphas/(4.d0*pi))**2*(b1+2.d0*b0*a1) c2=(alphas/(4.d0*pi))**2*b0**2 else if (npot.eq.5) then else write (*,*) ' Potential not implemented! Stop. 4' stop endif phiint=cnspot*alphas c cctt No cut-off description used here either. c if (max(xk,p).lt.dcut) then cctt Pure Coulomb in first order and second order only: c xkpln1st=-(xk/p)**2*(1.d0+(xk**2+p**2)/(2.d0*xk*p)* u (dlog(dabs(p-xk))-dlog(p+xk))) c xkpln1st=-(xk/p)**2*(1.d0+(xk**2+p**2)/(4.d0*xk*p)* c u (dlog((p-xk)**2)-2.d0*dlog(p+xk))) c xkpln2nd=((xk/p)**2/2.d0+xk*(xk**2+p**2)/8.d0/p**3* u (dlog((p-xk)**2)-2.d0*dlog(p+xk)))* u (-2.d0+dlog((xk-p)**2/scale**2) u +dlog((xk+p)**2/scale**2)) c cctt 3rd order not yet. xkpln3rd= if (c2.ne.0.d0) then write(*,*) ' Vhhat: 2nd order not implemented yet. Stop.' stop endif c cctt vhhat=dcmplx(phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd), cctt u 0.d0) vhhat=cmplx(phiint*(c0*xkpln1st+c1*xkpln2nd), u 0.d0,kind=kind(0d0)) c else c vhhat=(0.d0,0.d0) c endif c end c c c c c --- Routines for solving linear equations and matrix inversion (complex) --- c subroutine saeax(pp, w1, bb, vec, a1, n) c implicit none complex*16 vhatax,vhhat real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u d, d1, pp, w1, gtpcor,hmass, u xp,xpmax,dcut,kincom,kincoa,kincov complex*16 aax, a1, bb, vec, ff, kk, cw, svw, g0, g0c integer i, j, npot, n, nmax, indx,kinflg,gcflg,vflag parameter (nmax=900) dimension bb(nmax),vec(nmax),ff(nmax,nmax),kk(nmax,nmax), u pp(nmax),w1(nmax),indx(nmax),cw(nmax),a1(nmax) c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/mom/ xp,xpmax,dcut common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag c external aax, vhatax, gtpcor, g0, g0c, vhhat c do 10 i=1,n*2/3 cw(i) = w1(i) / (4.d0*pi**2) * g0c(pp(i)) c cw(i) = w1(i) / (4.d0*pi**2 * c u (cmplx(energy-vzero, tgamma* c u gtpcor(pp(i),2.d0*tmass+energy), c u kind=kind(0d0))-pp(i)**2/tmass)) 10 continue do 20 i=n*2/3+1,n cw(i) = w1(i) / (4.d0*pi**2) * g0c(pp(i)) * pp(i)**2 c cw(i) = w1(i) / (4.d0*pi**2 * c u (cmplx(energy-vzero, tgamma* c u gtpcor(pp(i),2.d0*tmass+energy),kind=kind(0d0)) / c u pp(i)**2 - 1.d0/tmass)) 20 continue c do 30 i=1,n cc bb(i) = a1(i) cvv if (pp(i).lt.dcut.and.vflag.eq.1) then c bb(i) = cmplx(1.d0+kincov*(pp(i)/tmass)**2,0.d0, c u kind=kind(0d0)) bb(i)=1.d0+kincov* u g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i)) else bb(i) = (1.d0,0.d0) endif c c Without extra kinematic corrections: vec(i)=(1.d0,0.d0) c svw = (0.d0,0.d0) do 40 j=1,n if (i.ne.j) then ff(i,j) = - vhatax(pp(i),pp(j)) * cw(j) kk(i,j) = - vhhat(pp(i),pp(j)) * cw(j) svw = svw + ff(i,j) endif 40 continue ff(i,i) = 1.d0 - a1(i) - svw kk(i,i) = ff(i,i) 30 continue c call zldcmp(ff, n, nmax, indx, d) call zldcmp(kk, n, nmax, indx, d1) call zlbksb(ff, n, nmax, indx, bb) call zlbksb(kk, n, nmax, indx, vec) c end c c @ <<[[ttv_formfactors.f90]]>>= <> module ttv_formfactors use kinds <> use constants use numeric_utils use physics_defs, only: CF, CA, TR use sm_physics use lorentz use interpolation use nr_tools use io_units, only: free_unit, given_output_unit use string_utils use iso_varying_string, string_t => varying_string use system_dependencies use, intrinsic :: iso_fortran_env !NODEP! use diagnostics <> save <> <> <> <> <> contains <> end module ttv_formfactors @ %def ttv_formfactors @ <>= public :: onshell_projection_t <>= type :: onshell_projection_t logical :: production logical :: decay logical :: width logical :: boost_decay contains <> end type onshell_projection_t @ %def onshell_projection_t @ <>= procedure :: debug_write => onshell_projection_debug_write <>= subroutine onshell_projection_debug_write (onshell_projection) class(onshell_projection_t), intent(in) :: onshell_projection if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%production", & onshell_projection%production) if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%decay", & onshell_projection%decay) if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%width", & onshell_projection%width) if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%boost_decay", & onshell_projection%boost_decay) end subroutine onshell_projection_debug_write @ %def onshell_projection_debug_write @ <>= procedure :: set_all => onshell_projection_set_all <>= pure subroutine onshell_projection_set_all (onshell_projection, flag) class(onshell_projection_t), intent(inout) :: onshell_projection logical, intent(in) :: flag onshell_projection%production = flag onshell_projection%decay = flag end subroutine onshell_projection_set_all @ %def onshell_projection_set_all @ <>= procedure :: active => onshell_projection_active <>= pure function onshell_projection_active (onshell_projection) result (active) logical :: active class(onshell_projection_t), intent(in) :: onshell_projection active = onshell_projection%production .or. & onshell_projection%decay end function onshell_projection_active @ %def onshell_projection_active @ <>= type :: helicity_approximation_t logical :: simple = .false. logical :: extra = .false. logical :: ultra = .false. contains <> end type helicity_approximation_t @ %def helicity_approximation_t @ <>= public :: settings_t <>= type :: settings_t ! look what is set by initialized_parameters, bundle them in a class and rename to initialized logical :: initialized_parameters ! this belongs to init_threshold_phase_space_grid in phase_space_grid_t logical :: initialized_ps ! this belongs to the ff_grid_t, its usefulness is doubtful logical :: initialized_ff logical :: mpole_dynamic integer :: offshell_strategy logical :: factorized_computation logical :: interference logical :: only_interference_term logical :: nlo logical :: no_nlo_width_in_signal_propagators logical :: force_minus_one logical :: flip_relative_sign integer :: sel_hel_top = 0 integer :: sel_hel_topbar = 0 logical :: Z_disabled type(onshell_projection_t) :: onshell_projection type(helicity_approximation_t) :: helicity_approximation contains <> end type settings_t @ %def settings_t @ <>= procedure :: setup_flags => settings_setup_flags <>= ! TODO: (bcn 2016-03-21) break this up into a part regarding the ! FF grid and a part regarding the settings subroutine settings_setup_flags (settings, ff_in, offshell_strategy_in, & top_helicity_selection) class(settings_t), intent(inout) :: settings integer, intent(in) :: ff_in, offshell_strategy_in, top_helicity_selection logical :: bit_top, bit_topbar !!! RESUMMED_SWITCHOFF = - 2 !!! MATCHED = -1, & SWITCHOFF_RESUMMED = ff_in < 0 TOPPIK_RESUMMED = ff_in <= 1 settings%nlo = btest(offshell_strategy_in, 0) settings%factorized_computation = btest(offshell_strategy_in, 1) settings%interference = btest(offshell_strategy_in, 2) call settings%onshell_projection%set_all(btest(offshell_strategy_in, 3)) settings%no_nlo_width_in_signal_propagators = btest(offshell_strategy_in, 4) settings%helicity_approximation%simple = btest(offshell_strategy_in, 5) if (.not. settings%onshell_projection%active ()) then settings%onshell_projection%production = btest(offshell_strategy_in, 6) settings%onshell_projection%decay = btest(offshell_strategy_in, 7) end if settings%onshell_projection%width = .not. btest(offshell_strategy_in, 8) settings%onshell_projection%boost_decay = btest(offshell_strategy_in, 9) settings%helicity_approximation%extra = btest(offshell_strategy_in, 10) settings%force_minus_one = btest(offshell_strategy_in, 11) settings%flip_relative_sign = btest(offshell_strategy_in, 12) if (top_helicity_selection > -1) then settings%helicity_approximation%ultra = .true. bit_top = btest (top_helicity_selection, 0) bit_topbar = btest (top_helicity_selection, 1) if (bit_top) then settings%sel_hel_top = 1 else settings%sel_hel_top = -1 end if if (bit_topbar) then settings%sel_hel_topbar = 1 else settings%sel_hel_topbar = -1 end if end if settings%only_interference_term = btest(offshell_strategy_in, 14) settings%Z_disabled = btest(offshell_strategy_in, 15) if (ff_in == MATCHED .or. ff_in == MATCHED_NOTSOHARD) then settings%onshell_projection%width = .true. settings%onshell_projection%production = .true. settings%onshell_projection%decay = .true. settings%factorized_computation = .true. settings%interference = .true. settings%onshell_projection%boost_decay = .true. end if if (debug_on) call msg_debug (D_THRESHOLD, "SWITCHOFF_RESUMMED", SWITCHOFF_RESUMMED) if (debug_on) call msg_debug (D_THRESHOLD, "TOPPIK_RESUMMED", TOPPIK_RESUMMED) if (debug_active (D_THRESHOLD)) & call settings%write () end subroutine settings_setup_flags @ %def settings_setup_flags @ <>= procedure :: write => settings_write <>= subroutine settings_write (settings, unit) class(settings_t), intent(in) :: settings integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, '(A,L1)') "settings%helicity_approximation%simple = ", & settings%helicity_approximation%simple write (u, '(A,L1)') "settings%helicity_approximation%extra = ", & settings%helicity_approximation%extra write (u, '(A,L1)') "settings%helicity_approximation%ultra = ", & settings%helicity_approximation%ultra write (u, '(A,L1)') "settings%initialized_parameters = ", & settings%initialized_parameters write (u, '(A,L1)') "settings%initialized_ps = ", & settings%initialized_ps write (u, '(A,L1)') "settings%initialized_ff = ", & settings%initialized_ff write (u, '(A,L1)') "settings%mpole_dynamic = ", & settings%mpole_dynamic write (u, '(A,I5)') "settings%offshell_strategy = ", & settings%offshell_strategy write (u, '(A,L1)') "settings%factorized_computation = ", & settings%factorized_computation write (u, '(A,L1)') "settings%interference = ", settings%interference write (u, '(A,L1)') "settings%only_interference_term = ", & settings%only_interference_term write (u, '(A,L1)') "settings%Z_disabled = ", & settings%Z_disabled write (u, '(A,L1)') "settings%nlo = ", settings%nlo write (u, '(A,L1)') "settings%no_nlo_width_in_signal_propagators = ", & settings%no_nlo_width_in_signal_propagators write (u, '(A,L1)') "settings%force_minus_one = ", settings%force_minus_one write (u, '(A,L1)') "settings%flip_relative_sign = ", settings%flip_relative_sign call settings%onshell_projection%debug_write () end subroutine settings_write @ %def settings_write @ <>= procedure :: use_nlo_width => settings_use_nlo_width <>= pure function settings_use_nlo_width (settings, ff) result (nlo) logical :: nlo class(settings_t), intent(in) :: settings integer, intent(in) :: ff nlo = settings%nlo end function settings_use_nlo_width @ %def settings_use_nlo_width @ <>= public :: formfactor_t <>= type :: formfactor_t logical :: active contains <> end type formfactor_t @ %def formfactor_t @ <>= procedure :: activate => formfactor_activate <>= pure subroutine formfactor_activate (formfactor) class(formfactor_t), intent(inout) :: formfactor formfactor%active = .true. end subroutine formfactor_activate @ %def formfactor_activate @ <>= procedure :: disable => formfactor_disable <>= pure subroutine formfactor_disable (formfactor) class(formfactor_t), intent(inout) :: formfactor formfactor%active = .false. end subroutine formfactor_disable @ %def formfactor_disable @ This function actually returns $\tilde{F}$, i.e. $F-1$. <>= procedure :: compute => formfactor_compute <>= function formfactor_compute (formfactor, ps, vec_type, FF_mode) result (FF) complex(default) :: FF class(formfactor_t), intent(in) :: formfactor type(phase_space_point_t), intent(in) :: ps integer, intent(in) :: vec_type, FF_mode real(default) :: f if (threshold%settings%initialized_parameters .and. formfactor%active) then select case (FF_mode) case (MATCHED, MATCHED_NOTSOHARD, RESUMMED, RESUMMED_SWITCHOFF) FF = resummed_formfactor (ps, vec_type) - one case (MATCHED_EXPANDED) f = f_switch_off (v_matching (ps%sqrts, GAM_M1S)) FF = - expanded_formfactor (f * AS_HARD, f * AS_HARD, ps, vec_type) & + resummed_formfactor (ps, vec_type) case (MATCHED_EXPANDED_NOTSOHARD) f = f_switch_off (v_matching (ps%sqrts, GAM_M1S)) FF = - expanded_formfactor (f * alphas_notsohard (ps%sqrts), f * & alphas_notsohard (ps%sqrts), ps, vec_type) & + resummed_formfactor (ps, vec_type) case (EXPANDED_HARD) FF = expanded_formfactor (AS_HARD, AS_HARD, ps, vec_type) - one case (EXPANDED_NOTSOHARD) FF = expanded_formfactor (alphas_notsohard (ps%sqrts), & alphas_notsohard (ps%sqrts), ps, vec_type) - one case (EXPANDED_SOFT) FF = expanded_formfactor (AS_HARD, alphas_soft (ps%sqrts), ps, & vec_type) - one case (EXPANDED_SOFT_SWITCHOFF) f = f_switch_off (v_matching (ps%sqrts, GAM_M1S)) FF = expanded_formfactor (f * AS_HARD, & f * alphas_soft (ps%sqrts), ps, vec_type) - one case (RESUMMED_ANALYTIC_LL) FF = formfactor_LL_analytic (alphas_soft (ps%sqrts), ps%sqrts, & ps%p, vec_type) - one case (TREE) FF = zero case default FF = zero end select else FF = zero end if if (debug2_active (D_THRESHOLD)) then call update_global_sqrts_dependent_variables (ps%sqrts) call msg_debug2 (D_THRESHOLD, "threshold%settings%initialized_parameters", threshold%settings%initialized_parameters) call msg_debug2 (D_THRESHOLD, "formfactor%active", formfactor%active) call msg_debug2 (D_THRESHOLD, "FF_mode", FF_mode) call msg_debug2 (D_THRESHOLD, "FF", FF) call msg_debug2 (D_THRESHOLD, "v", sqrts_to_v (ps%sqrts, GAM)) call msg_debug2 (D_THRESHOLD, "vec_type", vec_type) call ps%write () end if end function formfactor_compute @ %def formfactor_compute @ <>= public :: width_t <>= type :: width_t real(default) :: aem real(default) :: sw real(default) :: mw real(default) :: mb real(default) :: vtb real(default) :: gam_inv contains <> end type width_t @ %def width_t @ <>= procedure :: init => width_init <>= pure subroutine width_init (width, aemi, sw, mw, mb, vtb, gam_inv) class(width_t), intent(inout) :: width real(default), intent(in) :: aemi, sw, mw, mb, vtb, gam_inv width%aem = one / aemi width%sw = sw width%mw = mw width%mb = mb width%vtb = vtb width%gam_inv = gam_inv end subroutine width_init @ %def width_init @ <>= procedure :: compute => width_compute <>= pure function width_compute (width, top_mass, sqrts, initial) result (gamma) real(default) :: gamma class(width_t), intent(in) :: width real(default), intent(in) :: top_mass, sqrts logical, intent(in), optional :: initial real(default) :: alphas logical :: ini ini = .false.; if (present (initial)) ini = initial if (ini) then alphas = AS_HARD else alphas = alphas_notsohard (sqrts) end if if (threshold%settings%nlo) then gamma = top_width_sm_qcd_nlo_jk (width%aem, width%sw, width%vtb, & top_mass, width%mw, width%mb, alphas) + width%gam_inv else gamma = top_width_sm_lo (width%aem, width%sw, width%vtb, top_mass, & width%mw, width%mb) + width%gam_inv end if end function width_compute @ %def width_compute @ Use singleton pattern instead of global variables. At least shows where the variables are from. <>= public :: threshold <>= type(threshold_t) :: threshold <>= public :: threshold_t <>= type :: threshold_t type(settings_t) :: settings type(formfactor_t) :: formfactor type(width_t) :: width contains <> end type threshold_t @ %def threshold_t @ <>= integer, parameter :: VECTOR = 1 integer, parameter :: AXIAL = 2 integer, parameter, public :: MATCHED_EXPANDED_NOTSOHARD = -5, & MATCHED_NOTSOHARD = -4, & MATCHED_EXPANDED = - 3, & RESUMMED_SWITCHOFF = - 2, & MATCHED = -1, & RESUMMED = 1, & EXPANDED_HARD = 4, & EXPANDED_SOFT = 5, & EXPANDED_SOFT_SWITCHOFF = 6, & RESUMMED_ANALYTIC_LL = 7, & EXPANDED_NOTSOHARD = 8, & TREE = 9 real(default), parameter :: NF = 5.0_default real(default), parameter :: z3 = 1.20205690315959428539973816151_default real(default), parameter :: A1 = 31./9.*CA - 20./9.*TR*NF real(default), parameter :: A2 = (4343./162. + 4.*pi**2 - pi**4/4. + & 22./3.*z3)*CA**2 - (1798./81. + 56./3.*z3)*CA*TR*NF - & (55./3. - 16.*z3)*CF*TR*NF + (20./9.*TR*NF)**2 complex(default), parameter :: ieps = imago*tiny_10 @ [[gam_m1s]] is only used for the scale nustar <>= public :: GAM, GAM_M1S <>= real(default) :: M1S, GAM, GAM_M1S integer :: NRQCD_ORDER real(default) :: MTPOLE = - one real(default) :: mtpole_init real(default) :: RESCALE_H, MU_HARD, AS_HARD real(default) :: AS_MZ, MASS_Z real(default) :: MU_USOFT, AS_USOFT @ [[NUSTAR_FIXED]] is normally not used <>= public :: AS_SOFT public :: AS_LL_SOFT public :: AS_USOFT public :: AS_HARD public :: SWITCHOFF_RESUMMED public :: TOPPIK_RESUMMED <>= real(default) :: RESCALE_F, MU_SOFT, AS_SOFT, AS_LL_SOFT, NUSTAR_FIXED logical :: NUSTAR_DYNAMIC, SWITCHOFF_RESUMMED, TOPPIK_RESUMMED real(default) :: B0 real(default) :: B1 real(default), dimension(2) :: aa2, aa3, aa4, aa5, aa8, aa0 character(len=200) :: parameters_ref type(nr_spline_t) :: ff_p_spline real(default) :: v1, v2 integer :: POINTS_SQ, POINTS_P, POINTS_P0, n_q real(default), dimension(:), allocatable :: sq_grid, p_grid, p0_grid, q_grid complex(default), dimension(:,:,:,:), allocatable :: ff_grid complex(single), dimension(:,:,:,:,:), allocatable :: Vmatrix @ Explicit range and step size of the sqrts-grid relative to 2*M1S: <>= real(default) :: sqrts_min, sqrts_max, sqrts_it @ <>= interface char module procedure int_to_char, real_to_char, complex_to_char, logical_to_char end interface char <>= public :: m1s_to_mpole @ <>= type, public :: phase_space_point_t real(default) :: p2 = 0, k2 = 0, q2 = 0 real(default) :: sqrts = 0, p = 0, p0 = 0 real(default) :: mpole = 0, en = 0 logical :: inside_grid = .false., onshell = .false. contains <> end type phase_space_point_t @ <>= procedure :: init => phase_space_point_init_rel <>= pure subroutine phase_space_point_init_rel (ps_point, p2, k2, q2, m) class(phase_space_point_t), intent(inout) :: ps_point real(default), intent(in) :: p2 real(default), intent(in) :: k2 real(default), intent(in) :: q2 real(default), intent(in), optional :: m ps_point%p2 = p2 ps_point%k2 = k2 ps_point%q2 = q2 call rel_to_nonrel (p2, k2, q2, ps_point%sqrts, ps_point%p, ps_point%p0) ps_point%mpole = m1s_to_mpole (ps_point%sqrts) ps_point%en = sqrts_to_en (ps_point%sqrts) ps_point%inside_grid = sqrts_within_range (ps_point%sqrts) if ( present(m) ) ps_point%onshell = ps_point%is_onshell (m) end subroutine phase_space_point_init_rel @ <>= procedure :: init_nonrel => phase_space_point_init_nonrel <>= pure subroutine phase_space_point_init_nonrel (ps_point, sqrts, p, p0, m) class(phase_space_point_t), intent(inout) :: ps_point real(default), intent(in) :: sqrts real(default), intent(in) :: p real(default), intent(in) :: p0 real(default), intent(in), optional :: m ps_point%sqrts = sqrts ps_point%p = p ps_point%p0 = p0 call nonrel_to_rel (sqrts, p, p0, ps_point%p2, ps_point%k2, ps_point%q2) ps_point%mpole = m1s_to_mpole (sqrts) ps_point%en = sqrts_to_en (sqrts, ps_point%mpole) ps_point%inside_grid = sqrts_within_range (sqrts) if ( present(m) ) ps_point%onshell = ps_point%is_onshell (m) end subroutine phase_space_point_init_nonrel @ <>= !!! convert squared 4-momenta into sqrts, p0 = E_top-sqrts/2 and abs. 3-momentum p pure subroutine rel_to_nonrel (p2, k2, q2, sqrts, p, p0) real(default), intent(in) :: p2 real(default), intent(in) :: k2 real(default), intent(in) :: q2 real(default), intent(out) :: sqrts real(default), intent(out) :: p real(default), intent(out) :: p0 sqrts = sqrt(q2) p0 = abs(p2 - k2) / (2. * sqrts) p = sqrt (0.5_default * (- p2 - k2 + sqrts**2/2. + 2.* p0**2)) end subroutine rel_to_nonrel @ <>= !!! convert sqrts, p0 = E_top-sqrts/2 and abs. 3-momentum p into squared 4-momenta pure subroutine nonrel_to_rel (sqrts, p, p0, p2, k2, q2) real(default), intent(in) :: sqrts real(default), intent(in) :: p real(default), intent(in) :: p0 real(default), intent(out) :: p2 real(default), intent(out) :: k2 real(default), intent(out) :: q2 p2 = (sqrts/2.+p0)**2 - p**2 k2 = (sqrts/2.-p0)**2 - p**2 q2 = sqrts**2 end subroutine nonrel_to_rel @ <>= pure function complex_m2 (m, w) result (m2c) real(default), intent(in) :: m real(default), intent(in) :: w complex(default) :: m2c m2c = m**2 - imago*m*w end function complex_m2 @ <>= procedure :: is_onshell => phase_space_point_is_onshell <>= pure function phase_space_point_is_onshell (ps_point, m) result (flag) logical :: flag class(phase_space_point_t), intent(in) :: ps_point real(default), intent(in) :: m flag = nearly_equal (ps_point%p2 , m**2, rel_smallness=1E-5_default) .and. & nearly_equal (ps_point%k2 , m**2, rel_smallness=1E-5_default) end function phase_space_point_is_onshell @ <>= procedure :: write => phase_space_point_write <>= subroutine phase_space_point_write (psp, unit) class(phase_space_point_t), intent(in) :: psp integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, '(A)') char ("p2 = " // str (psp%p2)) write (u, '(A)') char ("k2 = " // str (psp%k2)) write (u, '(A)') char ("q2 = " // str (psp%q2)) write (u, '(A)') char ("sqrts = " // str (psp%sqrts)) write (u, '(A)') char ("p = " // str (psp%p)) write (u, '(A)') char ("p0 = " // str (psp%p0)) write (u, '(A)') char ("mpole = " // str (psp%mpole)) write (u, '(A)') char ("en = " // str (psp%en)) write (u, '(A)') char ("inside_grid = " // str (psp%inside_grid)) write (u, '(A)') char ("onshell = " // str (psp%onshell)) end subroutine phase_space_point_write @ %def phase_space_point_write @ <>= function set_nrqcd_order (nrqcd_order_in) result (nrqcdorder) integer :: nrqcdorder real(default), intent(in) :: nrqcd_order_in nrqcdorder = 1 if ( int(nrqcd_order_in) > nrqcdorder ) then call msg_warning ("reset to highest available NRQCD_ORDER = " // char(nrqcdorder)) else nrqcdorder = int(nrqcd_order_in) end if end function set_nrqcd_order @ %def set_nrqcd_order @ <>= public :: init_parameters <>= subroutine init_parameters (mpole_out, gam_out, m1s_in, Vtb, gam_inv, & aemi, sw, az, mz, mw, mb, h_in, f_in, nrqcd_order_in, ff_in, & offshell_strategy_in, v1_in, v2_in, scan_sqrts_min, & scan_sqrts_max, scan_sqrts_stepsize, mpole_fixed, top_helicity_selection) real(default), intent(out) :: mpole_out real(default), intent(out) :: gam_out real(default), intent(in) :: m1s_in real(default), intent(in) :: Vtb real(default), intent(in) :: gam_inv real(default), intent(in) :: aemi real(default), intent(in) :: sw real(default), intent(in) :: az real(default), intent(in) :: mz real(default), intent(in) :: mw real(default), intent(in) :: mb real(default), intent(in) :: h_in real(default), intent(in) :: f_in real(default), intent(in) :: nrqcd_order_in real(default), intent(in) :: ff_in real(default), intent(in) :: offshell_strategy_in real(default), intent(in) :: v1_in real(default), intent(in) :: v2_in real(default), intent(in) :: scan_sqrts_min real(default), intent(in) :: scan_sqrts_max real(default), intent(in) :: scan_sqrts_stepsize logical, intent(in) :: mpole_fixed real(default), intent(in) :: top_helicity_selection if (debug_active (D_THRESHOLD)) call show_input() threshold%settings%initialized_parameters = .false. M1S = m1s_in threshold%settings%mpole_dynamic = .not. mpole_fixed threshold%settings%offshell_strategy = int (offshell_strategy_in) call threshold%settings%setup_flags (int(ff_in), & threshold%settings%offshell_strategy, & int (top_helicity_selection)) NRQCD_ORDER = set_nrqcd_order (nrqcd_order_in) v1 = v1_in v2 = v2_in sqrts_min = scan_sqrts_min sqrts_max = scan_sqrts_max sqrts_it = scan_sqrts_stepsize !!! global hard parameters incl. hard alphas used in all form factors RESCALE_H = h_in MU_HARD = M1S * RESCALE_H AS_MZ = az MASS_Z = mz AS_HARD = running_as (MU_HARD, az, mz, 2, NF) call threshold%width%init (aemi, sw, mw, mb, vtb, gam_inv) GAM_M1S = threshold%width%compute (M1S, zero, initial=.true.) call compute_global_auxiliary_numbers () !!! soft parameters incl. mtpole !!! (depend on sqrts: initialize with sqrts ~ 2*M1S) NUSTAR_FIXED = - one NUSTAR_DYNAMIC = NUSTAR_FIXED < zero RESCALE_F = f_in call update_global_sqrts_dependent_variables (2. * M1S) mtpole_init = MTPOLE mpole_out = mtpole_init gam_out = GAM threshold%settings%initialized_parameters = .true. contains <> end subroutine init_parameters @ <>= subroutine show_input() if (debug_on) call msg_debug (D_THRESHOLD, "init_parameters") if (debug_on) call msg_debug (D_THRESHOLD, "m1s_in", m1s_in) if (debug_on) call msg_debug (D_THRESHOLD, "Vtb", Vtb) if (debug_on) call msg_debug (D_THRESHOLD, "gam_inv", gam_inv) if (debug_on) call msg_debug (D_THRESHOLD, "aemi", aemi) if (debug_on) call msg_debug (D_THRESHOLD, "sw", sw) if (debug_on) call msg_debug (D_THRESHOLD, "az", az) if (debug_on) call msg_debug (D_THRESHOLD, "mz", mz) if (debug_on) call msg_debug (D_THRESHOLD, "mw", mw) if (debug_on) call msg_debug (D_THRESHOLD, "mb", mb) if (debug_on) call msg_debug (D_THRESHOLD, "h_in", h_in) if (debug_on) call msg_debug (D_THRESHOLD, "f_in", f_in) if (debug_on) call msg_debug (D_THRESHOLD, "nrqcd_order_in", nrqcd_order_in) if (debug_on) call msg_debug (D_THRESHOLD, "ff_in", ff_in) if (debug_on) call msg_debug (D_THRESHOLD, "offshell_strategy_in", offshell_strategy_in) if (debug_on) call msg_debug (D_THRESHOLD, "top_helicity_selection", top_helicity_selection) if (debug_on) call msg_debug (D_THRESHOLD, "v1_in", v1_in) if (debug_on) call msg_debug (D_THRESHOLD, "v2_in", v2_in) if (debug_on) call msg_debug (D_THRESHOLD, "scan_sqrts_min", scan_sqrts_min) if (debug_on) call msg_debug (D_THRESHOLD, "scan_sqrts_max", scan_sqrts_max) if (debug_on) call msg_debug (D_THRESHOLD, "scan_sqrts_stepsize", scan_sqrts_stepsize) if (debug_on) call msg_debug (D_THRESHOLD, "AS_HARD", AS_HARD) end subroutine show_input @ <>= subroutine compute_global_auxiliary_numbers () !!! auxiliary numbers needed later !!! current coefficients Ai(S,L,J), cf. arXiv:hep-ph/0609151, Eqs. (63)-(64) !!! 3S1 coefficients (s-wave, vector current) B0 = coeff_b0(NF) * (4.*pi) B1 = coeff_b1(NF) * (4.*pi)**2 aa2(1) = (CF*(CA*CF*(9.*CA - 100.*CF) - & B0*(26.*CA**2 + 19.*CA*CF - 32.*CF**2)))/(26.*B0**2 *CA) aa3(1) = CF**2/( B0**2 *(6.*B0 - 13.*CA)*(B0 - 2.*CA)) * & (CA**2 *(9.*CA - 100.*CF) + B0*CA*(74.*CF - CA*16.) - & 6.*B0**2 *(2.*CF - CA)) aa4(1) = (24.*CF**2 * (11.*CA - 3.*B0)*(5.*CA + 8.*CF)) / & (13.*CA*(6.*B0 - 13.*CA)**2) aa5(1) = (CF**2 * (CA*(15.-28) + B0*5.))/(6.*(B0-2.*CA)**2) aa8(1) = zero aa0(1) = -((8.*CF*(CA + CF)*(CA + 2.*CF))/(3.*B0**2)) !!! 3P1 coefficients (p-wave, axial vector current) aa2(2) = -1./3. * (CF*(CA+2.*CF)/B0 - CF**2/(4.*B0) ) aa3(2) = zero aa4(2) = zero aa5(2) = 1./3. * CF**2/(4.*(B0-2.*CA)) aa8(2) = -1./3. * CF**2/(B0-CA) aa0(2) = -1./3. * 8.*CA*CF*(CA+4.*CF)/(3.*B0**2) end subroutine compute_global_auxiliary_numbers @ %def compute_global_auxiliary_numbers @ <>= public :: init_threshold_grids <>= subroutine init_threshold_grids (test) real(default), intent(in) :: test if (debug_active (D_THRESHOLD)) then call msg_debug (D_THRESHOLD, "init_threshold_grids") call msg_debug (D_THRESHOLD, "TOPPIK_RESUMMED", TOPPIK_RESUMMED) end if if (test > zero) then call msg_message ("TESTING ONLY: Skip threshold initialization and use tree-level SM.") return end if if (.not. threshold%settings%initialized_parameters) call msg_fatal ("init_threshold_grid: parameters not initialized!") !!! !!! !!! MAC OS X and BSD don't load the global module with parameter values stored !!! if (parameters_ref == parameters_string ()) return call dealloc_grids () if (TOPPIK_RESUMMED) call init_formfactor_grid () parameters_ref = parameters_string () end subroutine init_threshold_grids @ <>= !!! LL/NLL resummation of nonrelativistic Coulomb potential pure function resummed_formfactor (ps, vec_type) result (c) type(phase_space_point_t), intent(in) :: ps integer, intent(in) :: vec_type complex(default) :: c c = one if (.not. threshold%settings%initialized_ff .or. .not. ps%inside_grid) return if (POINTS_SQ > 1) then call interpolate_linear (sq_grid, p_grid, ff_grid(:,:,1,vec_type), ps%sqrts, ps%p, c) else call interpolate_linear (p_grid, ff_grid(1,:,1,vec_type), ps%p, c) end if end function resummed_formfactor @ <>= !!! leading nonrelativistic O(alphas^1) contribution (-> expansion of resummation) function expanded_formfactor (alphas_hard, alphas_soft, ps, vec_type) result (FF) complex(default) :: FF real(default), intent(in) :: alphas_hard, alphas_soft type(phase_space_point_t), intent(in) :: ps integer, intent(in) :: vec_type real(default) :: shift_from_hard_current complex(default) :: v, contrib_from_potential FF = one if (.not. threshold%settings%initialized_parameters) return call update_global_sqrts_dependent_variables (ps%sqrts) v = sqrts_to_v (ps%sqrts, GAM) if (NRQCD_ORDER == 1) then if (vec_type == AXIAL) then shift_from_hard_current = - CF / pi else shift_from_hard_current = - two * CF / pi end if else shift_from_hard_current = zero end if if (ps%onshell) then contrib_from_potential = CF * ps%mpole * Pi / (4 * ps%p) else if (vec_type == AXIAL) then contrib_from_potential = - CF * ps%mpole / (two * ps%p) * & (imago * ps%mpole * v / ps%p + & - (ps%mpole**2 * v**2 + (ps%p)**2 / (4 *Pi * (ps%p)**2) * ( & + (ps%mpole**2 * v**2 + (ps%p)**2) / (4 *Pi * (ps%p)**2) * ( & (log (- ps%mpole * v - ps%p))**2 - & (log (- ps%mpole * v + ps%p))**2 + & (log (ps%mpole * v - ps%p))**2 - & - (log (ps%mpole * v + ps%p))**2 ))) + (log (ps%mpole * v + ps%p))**2 )) else contrib_from_potential = imago * CF * ps%mpole * & log ((ps%p + ps%mpole * v) / & (-ps%p + ps%mpole * v) + ieps) / (two * ps%p) end if end if FF = one + alphas_soft * contrib_from_potential + & alphas_hard * shift_from_hard_current end function expanded_formfactor @ <>= subroutine init_formfactor_grid () type(string_t) :: ff_file if (debug_on) call msg_debug (D_THRESHOLD, "init_formfactor_grid") threshold%settings%initialized_ff = .false. ff_file = "SM_tt_threshold.grid" call msg_message () call msg_message ("%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%") call msg_message (" Initialize e+e- => ttbar threshold resummation:") call msg_message (" Use analytic (LL) or TOPPIK (NLL) form factors for ttA/ttZ vector") call msg_message (" and axial vector couplings (S/P-wave) in the threshold region.") call msg_message (" Cf. threshold shapes from A. Hoang et al.: [arXiv:hep-ph/0107144],") call msg_message (" [arXiv:1309.6323].") if (NRQCD_ORDER > 0) then call msg_message (" Numerical NLL solutions calculated with TOPPIK [arXiv:hep-ph/9904468]") call msg_message (" by M. Jezabek, T. Teubner.") end if call msg_message ("%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%") call msg_message () call read_formfactor_grid (ff_file) if (.not. threshold%settings%initialized_ff) then if (.not. threshold%settings%initialized_ps) call init_threshold_phase_space_grid () call scan_formfactor_over_phase_space_grid () call write_formfactor_grid (ff_file) end if end subroutine init_formfactor_grid @ <>= subroutine read_formfactor_grid (ff_file) type(string_t), intent(in) :: ff_file complex(single), dimension(:,:,:,:), allocatable :: ff_grid_sp character(len(parameters_ref)) :: parameters integer :: u, st logical :: ex integer, dimension(4) :: ff_shape if (debug_on) call msg_debug (D_THRESHOLD, "read_formfactor_grid") inquire (file=char(ff_file), exist=ex) if (.not. ex) return u = free_unit () call msg_message ("Opening grid file: " // char(ff_file)) open (unit=u, status='old', file=char(ff_file), form='unformatted', iostat=st) if (st /= 0) call msg_fatal ("iostat = " // char(st)) read (u) parameters read (u) ff_shape if (ff_shape(4) /= 2) call msg_fatal ("read_formfactor_grid: i = " // char(ff_shape(4))) if (parameters /= parameters_string ()) then call msg_message ("Threshold setup has changed: recalculate threshold grid.") close (unit=u, status='delete') return end if call msg_message ("Threshold setup unchanged: reusing existing threshold grid.") POINTS_SQ = ff_shape(1) POINTS_P = ff_shape(2) if (debug_active (D_THRESHOLD)) then call msg_debug (D_THRESHOLD, "ff_shape(1) (POINTS_SQ)", ff_shape(1)) call msg_debug (D_THRESHOLD, "ff_shape(2)", ff_shape(2)) call msg_debug (D_THRESHOLD, "ff_shape(3) (POINTS_P0)", ff_shape(3)) call msg_debug (D_THRESHOLD, "ff_shape(4) (==2)", ff_shape(4)) end if allocate (sq_grid(POINTS_SQ)) read (u) sq_grid allocate (p_grid(POINTS_P)) read (u) p_grid POINTS_P0 = ff_shape(3) allocate (ff_grid_sp(POINTS_SQ,POINTS_P,POINTS_P0,2)) read (u) ff_grid_sp allocate (ff_grid(POINTS_SQ,POINTS_P,POINTS_P0,2)) ff_grid = cmplx (ff_grid_sp, kind=default) close (u, iostat=st) if (st > 0) call msg_fatal ("close " // char(ff_file) // ": iostat = " // char(st)) threshold%settings%initialized_ps = .true. threshold%settings%initialized_ff = .true. end subroutine read_formfactor_grid @ <>= subroutine write_formfactor_grid (ff_file) type(string_t), intent(in) :: ff_file integer :: u, st if (.not. threshold%settings%initialized_ff) then call msg_warning ("write_formfactor_grid: no grids initialized!") return end if u = free_unit () open (unit=u, status='replace', file=char(ff_file), form='unformatted', iostat=st) if (st /= 0) call msg_fatal ("open " // char(ff_file) // ": iostat = " // char(st)) write (u) parameters_string () write (u) shape(ff_grid) write (u) sq_grid write (u) p_grid write (u) cmplx(ff_grid, kind=single) close (u, iostat=st) if (st > 0) call msg_fatal ("close " // char(ff_file) // ": iostat = " // char(st)) end subroutine write_formfactor_grid @ <>= pure function parameters_string () result (str) character(len(parameters_ref)) :: str str = char(M1S) // " " // char(GAM_M1S) // " " // char(NRQCD_ORDER) & // " " // char(RESCALE_H) & // " " // char(RESCALE_F) & // " " // char(sqrts_min) & // " " // char(sqrts_max) // " " // char(sqrts_it) end function parameters_string @ <>= subroutine update_global_sqrts_dependent_variables (sqrts) real(default), intent(in) :: sqrts real(default) :: nu_soft, f logical :: only_once_for_fixed_nu, already_done real(default), save :: last_sqrts = - one if (debug_on) call msg_debug (D_THRESHOLD, "update_global_sqrts_dependent_variables") if (debug_on) call msg_debug (D_THRESHOLD, "sqrts", sqrts) if (debug_on) call msg_debug (D_THRESHOLD, "last_sqrts", last_sqrts) already_done = threshold%settings%initialized_parameters .and. & nearly_equal (sqrts, last_sqrts, rel_smallness=1E-6_default) if (debug_on) call msg_debug (D_THRESHOLD, "already_done", already_done) only_once_for_fixed_nu = .not. NUSTAR_DYNAMIC .and. MTPOLE > zero if (debug_on) call msg_debug (D_THRESHOLD, "only_once_for_fixed_nu", only_once_for_fixed_nu) if (only_once_for_fixed_nu .or. already_done) return last_sqrts = sqrts nu_soft = RESCALE_F * nustar (sqrts) MU_SOFT = M1S * RESCALE_H * nu_soft MU_USOFT = M1S * RESCALE_H * nu_soft**2 AS_SOFT = running_as (MU_SOFT, AS_HARD, MU_HARD, NRQCD_ORDER, NF) AS_LL_SOFT = running_as (MU_SOFT, AS_HARD, MU_HARD, 0, NF) AS_USOFT = running_as (MU_USOFT, AS_HARD, MU_HARD, 0, NF) !!! LL here if (SWITCHOFF_RESUMMED) then f = f_switch_off (v_matching (sqrts, GAM_M1S)) AS_SOFT = AS_SOFT * f AS_LL_SOFT = AS_LL_SOFT * f AS_USOFT = AS_USOFT * f end if MTPOLE = m1s_to_mpole (sqrts) GAM = threshold%width%compute (MTPOLE, sqrts) if (debug_on) call msg_debug (D_THRESHOLD, "GAM", GAM) if (debug_on) call msg_debug (D_THRESHOLD, "nu_soft", nu_soft) if (debug_on) call msg_debug (D_THRESHOLD, "MTPOLE", MTPOLE) if (debug_on) call msg_debug (D_THRESHOLD, "AS_SOFT", AS_SOFT) if (debug_on) call msg_debug (D_THRESHOLD, "AS_LL_SOFT", AS_LL_SOFT) if (debug_on) call msg_debug (D_THRESHOLD, "AS_USOFT", AS_USOFT) end subroutine update_global_sqrts_dependent_variables !!! Coulomb potential coefficients needed by TOPPIK pure function xc (a_soft, i_xc) result (xci) real(default), intent(in) :: a_soft integer, intent(in) :: i_xc real(default) :: xci xci = zero select case (i_xc) case (0) xci = one if ( NRQCD_ORDER>0 ) xci = xci + a_soft/(4.*pi) * A1 if ( NRQCD_ORDER>1 ) xci = xci + (a_soft/(4.*pi))**2 * A2 case (1) if ( NRQCD_ORDER>0 ) xci = xci + a_soft/(4.*pi) * B0 if ( NRQCD_ORDER>1 ) xci = xci + (a_soft/(4.*pi))**2 * (B1 + 2*B0*A1) case (2) if ( NRQCD_ORDER>1 ) xci = xci + (a_soft/(4.*pi))**2 * B0**2 case default return end select end function xc @ <>= function current_coeff (a_hard, a_soft, a_usoft, i) result (coeff) real(default), intent(in) :: a_hard, a_soft, a_usoft integer, intent(in) :: i real(default) :: coeff real(default) :: matching_c, c1 real(default) :: z, w if (debug_on) call msg_debug (D_THRESHOLD, "current_coeff") coeff = one if (NRQCD_ORDER == 0) return z = a_soft / a_hard w = a_usoft / a_soft !!! hard s/p-wave 1-loop matching coefficients, cf. arXiv:hep-ph/0604072 select case (i) case (1) matching_c = one - 2.*(CF/pi) * a_hard case (2) matching_c = one - (CF/pi) * a_hard case default call msg_fatal ("current_coeff: unknown coeff i = " // char(i)) end select !!! current coefficient c1, cf. arXiv:hep-ph/0609151, Eq. (62) c1 = exp( a_hard * pi * ( aa2(i)*(1.-z) + aa3(i)*log(z) + & aa4(i)*(1.-z**(1.-13.*CA/(6.*B0))) + aa5(i)*(1.-z**(1.-2.*CA/B0)) + & aa8(i)*(1.-z**(1.-CA/B0)) + aa0(i)*(z-1.-log(w)/w) )) coeff = matching_c * c1 end function current_coeff @ <>= public :: v_matching <>= pure function v_matching (sqrts, gamma) result (v) real(default) :: v real(default), intent(in) :: sqrts, gamma v = abs (sqrts_to_v_1S (sqrts, gamma)) end function v_matching @ Smooth transition from [[f1]] to [[f2]] between [[v1]] and [[v2]] (simplest polynom). <>= public :: f_switch_off <>= pure function f_switch_off (v) result (fval) real(default), intent(in) :: v real(default) :: fval real(default) :: vm, f1, f2, x f1 = one f2 = zero + tiny_10 vm = (v1+v2) / 2. if ( v < v1 ) then fval = f1 else if (v < v2) then x = (v - v1) / (v2 - v1) fval = 1 - x**2 * (3 - 2 * x) else fval = f2 end if end function f_switch_off @ <>= function formfactor_LL_analytic (a_soft, sqrts, p, vec_type) result (c) real(default), intent(in) :: a_soft real(default), intent(in) :: sqrts real(default), intent(in) :: p integer, intent(in) :: vec_type complex(default) :: c real(default) :: en c = one if (.not. threshold%settings%initialized_parameters) return call update_global_sqrts_dependent_variables (sqrts) en = sqrts_to_en (sqrts, MTPOLE) select case (vec_type) case (1) c = G0p (CF*a_soft, en, p, MTPOLE, GAM) / G0p_tree (en, p, MTPOLE, GAM) case (2) c = G0p_ax (CF*a_soft, en, p, MTPOLE, GAM) / G0p_tree (en, p, MTPOLE, GAM) case default call msg_fatal ("unknown ttZ/ttA vertex component, vec_type = " // char(vec_type)) end select end function formfactor_LL_analytic @ <>= !!! Max's LL nonrelativistic threshold Green's function function G0p (a, en, p, m, w) result (c) real(default), intent(in) :: a real(default), intent(in) :: en real(default), intent(in) :: p real(default), intent(in) :: m real(default), intent(in) :: w complex(default) :: c complex(default) :: k, ipk, la, z1, z2 complex(default) :: one, two, cc, dd k = sqrt( -m*en -imago*m*w ) ipk = imago * p / k la = a * m / 2. / k one = cmplx (1., kind=default) two = cmplx (2., kind=default) cc = 2. - la dd = ( 1. + ipk ) / 2. z1 = nr_hypgeo (two, one, cc, dd) dd = ( 1. - ipk ) / 2. z2 = nr_hypgeo (two, one, cc, dd) c = - imago * m / (4.*p*k) / (1.-la) * ( z1 - z2 ) end function G0p @ <>= !!! tree level version: a_soft -> 0 pure function G0p_tree (en, p, m, w) result (c) real(default), intent(in) :: en real(default), intent(in) :: p real(default), intent(in) :: m real(default), intent(in) :: w complex(default) :: c c = m / (p**2 - m*(en+imago*w)) end function G0p_tree @ <>= !!! Peter Poier's LL nonrelativistic axial threshold Green's function function G0p_ax (a, en, p, m, w) result (c) real(default), intent(in) :: a real(default), intent(in) :: en real(default), intent(in) :: p real(default), intent(in) :: m real(default), intent(in) :: w complex(default) :: c complex(default) :: k, ipk, la, z1, z2, z3, z4 complex(default) :: zero, two, three, cc, ddp, ddm k = sqrt( -m*en -imago*m*w ) ipk = imago * p / k la = a * m / 2. / k zero = cmplx (0., kind=default) two = cmplx (2., kind=default) three = cmplx (3., kind=default) cc = 1. - la ddp = ( 1. + ipk ) / 2. ddm = ( 1. - ipk ) / 2. z1 = nr_hypgeo (zero, two, cc, ddp) z2 = nr_hypgeo (zero, two, cc, ddm) cc = 2. - la z3 = nr_hypgeo (zero, three, cc, ddm) z4 = nr_hypgeo (zero, three, cc, ddp) c = m / 2. / p**3 * ( 2.*p + imago*k*(1.-la)*(z1-z2) + imago*k*(z3-z4) ) end function G0p_ax @ <>= pure function nustar (sqrts) result (nu) real(default), intent(in) :: sqrts real(default) :: nu real(default), parameter :: nustar_offset = 0.05_default complex(default) :: arg if (NUSTAR_DYNAMIC) then !!! from [arXiv:1309.6323], Eq. (3.2) (other definitions possible) arg = ( sqrts - 2.*M1S + imago*GAM_M1S ) / M1S nu = nustar_offset + abs(sqrt(arg)) else nu = NUSTAR_FIXED end if end function nustar @ We recompute [[alpha_soft]] for form factors that do not call [[update_global_parameters]] (it is called in the scan for the (N)LL grid). <>= pure function alphas_soft (sqrts) result (a_soft) real(default) :: a_soft real(default), intent(in) :: sqrts real(default) :: mu_soft, nusoft nusoft = RESCALE_F * nustar (sqrts) mu_soft = RESCALE_H * M1S * nusoft a_soft = running_as (mu_soft, AS_HARD, MU_HARD, NRQCD_ORDER, NF) end function alphas_soft @ <>= public :: alphas_notsohard <>= pure function alphas_notsohard (sqrts) result (a_soft) real(default) :: a_soft real(default), intent(in) :: sqrts real(default) :: mu_notsohard ! complex(default) :: v ! v = sqrts_to_v_1S (sqrts, GAM_M1S) ! mu_notsohard = RESCALE_H * M1S * sqrt(abs(v)) mu_notsohard = RESCALE_H * M1S * sqrt(nustar (sqrts)) a_soft = running_as (mu_notsohard, AS_MZ, MASS_Z, 2, NF) end function alphas_notsohard @ <>= pure function m1s_to_mpole (sqrts) result (mpole) real(default), intent(in) :: sqrts real(default) :: mpole mpole = mtpole_init if (threshold%settings%mpole_dynamic) then mpole = M1S * ( 1. + deltaM(sqrts) ) else mpole = M1S end if end function m1s_to_mpole @ <>= !pure !function mpole_to_M1S (mpole, sqrts, nl) result (m) !real(default), intent(in) :: mpole !real(default), intent(in) :: sqrts !integer, intent(in) :: nl !real(default) :: m !m = mpole * ( 1. - deltaM(sqrts, nl) ) !end function mpole_to_M1S @ <>= pure function deltaM (sqrts) result (del) real(default), intent(in) :: sqrts real(default) :: del real(default) :: ac ac = CF * alphas_soft (sqrts) del = ac**2 / 8. if (NRQCD_ORDER > 0) then del = del + ac**3 / (8. * pi * CF) * & (B0 * (log (RESCALE_H * RESCALE_F * nustar (sqrts) / ac) + one) + A1 / 2.) end if end function deltaM @ <>= pure function sqrts_within_range (sqrts) result (flag) real(default), intent(in) :: sqrts logical :: flag flag = ( sqrts >= sqrts_min - tiny_07 .and. sqrts <= sqrts_max + tiny_07 ) end function @ <>= ! The mapping is such that even for min=max, we get three points: ! min - it , min, min + it pure function sqrts_iter (i_sq) result (sqrts) integer, intent(in) :: i_sq real(default) :: sqrts if (POINTS_SQ > 1) then sqrts = sqrts_min - sqrts_it + & (sqrts_max - sqrts_min + two * sqrts_it) * & real(i_sq - 1) / real(POINTS_SQ - 1) else sqrts = sqrts_min end if end function sqrts_iter @ <>= function scan_formfactor_over_p_LL_analytic (a_soft, sqrts, vec_type) result (ff_analytic) real(default), intent(in) :: a_soft real(default), intent(in) :: sqrts integer, intent(in) :: vec_type complex(default), dimension(POINTS_P) :: ff_analytic integer :: i_p ff_analytic = [(formfactor_LL_analytic (a_soft, sqrts, p_grid(i_p), vec_type), i_p=1, POINTS_P)] end function scan_formfactor_over_p_LL_analytic @ <>= !!! tttoppik wrapper subroutine scan_formfactor_over_p_TOPPIK (a_soft, sqrts, vec_type, p_grid_out, mpole_in, ff_toppik) real(default), intent(in) :: a_soft real(default), intent(in) :: sqrts integer, intent(in) :: vec_type real(default), dimension(POINTS_P), intent(out), optional :: p_grid_out real(default), intent(in), optional :: mpole_in complex(default), dimension(POINTS_P), optional :: ff_toppik integer :: i_p real(default) :: mpole, alphas_hard, f real(default), dimension(POINTS_P) :: p_toppik type(nr_spline_t) :: toppik_spline real*8 :: xenergy, xtm, xtg, xalphas, xscale, xc0, xc1, xc2, xim, xdi, & xcutn, xcutv, xkincm, xkinca, xkincv, xcdeltc, & xcdeltl, xcfullc, xcfulll, xcrm2 integer, parameter :: nmax=900 real*8 :: xdsdp(nmax), xpp(nmax), xww(nmax) complex*16 :: zff(nmax) integer :: np, jknflg, jgcflg, jvflg if (debug_on) call msg_debug (D_THRESHOLD, "scan_formfactor_over_p_TOPPIK") if (POINTS_P > nmax-40) call msg_fatal ("TOPPIK: POINTS_P must be <=" // char(nmax-40)) if (debug_on) call msg_debug (D_THRESHOLD, "POINTS_P", POINTS_P) if (present (ff_toppik)) ff_toppik = zero mpole = MTPOLE; if (present (mpole_in)) mpole = mpole_in xenergy = sqrts_to_en (sqrts, MTPOLE) xtm = mpole xtg = GAM xalphas = a_soft xscale = MU_SOFT xcutn = 175.E6 xcutv = 175.E6 xc0 = xc (a_soft, 0) xc1 = xc (a_soft, 1) xc2 = xc (a_soft, 2) xcdeltc = 0. xcdeltl = 0. xcfullc = 0. xcfulll = 0. xcrm2 = 0. xkincm = 0. xkinca = 0. jknflg = 0 jgcflg = 0 xkincv = 0. jvflg = 0 select case (vec_type) case (VECTOR) if (debug_on) call msg_debug (D_THRESHOLD, "calling tttoppik") call tttoppik & (xenergy,xtm,xtg,xalphas,xscale,xcutn,xcutv,xc0,xc1,xc2, & xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2,xkincm,xkinca,jknflg, & jgcflg, xkincv,jvflg,xim,xdi,np,xpp,xww,xdsdp,zff) case (AXIAL) if (debug_on) call msg_debug (D_THRESHOLD, "calling tttoppikaxial") call tttoppikaxial & (xenergy,xtm,xtg,xalphas,xscale,xcutn,xcutv,xc0,xc1,xc2, & xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2,xkincm,xkinca,jknflg, & jgcflg, xkincv,jvflg,xim,xdi,np,xpp,xww,xdsdp,zff) !!! 1st ~10 TOPPIK p-wave entries are ff_unstable: discard them zff(1:10) = [(zff(11), i_p=1, 10)] case default call msg_fatal ("unknown ttZ/ttA vertex component, vec_type = " // char(vec_type)) end select if (present (p_grid_out)) p_grid_out = xpp(1:POINTS_P) if (.not. present (ff_toppik)) return !!! keep track of TOPPIK instabilities and try to repair later if (np < 0) then ff_toppik(1) = 2.d30 if (debug_active (D_THRESHOLD)) then call msg_warning ("caught TOPPIK instability at sqrts = " // char(sqrts)) end if return end if p_toppik = xpp(1:POINTS_P) ff_toppik = zff(1:POINTS_P) !!! TOPPIK output p-grid scales with en above ~ 4 GeV: !!! interpolate for global sqrts/p grid if (.not. nearly_equal (p_toppik(42), p_grid(42), rel_smallness=1E-6_default)) then call toppik_spline%init (p_toppik, ff_toppik) ff_toppik(2:POINTS_P) = [(toppik_spline%interpolate (p_grid(i_p)), i_p=2, POINTS_P)] call toppik_spline%dealloc () end if !!! TOPPIK output includes tree level ~ 1, a_soft @ LL in current coefficient! if (SWITCHOFF_RESUMMED) then f = f_switch_off (v_matching (sqrts, GAM_M1S)) alphas_hard = AS_HARD * f else alphas_hard = AS_HARD end if ff_toppik = ff_toppik * current_coeff (alphas_hard, AS_LL_SOFT, AS_USOFT, vec_type) if (debug_on) call msg_debug (D_THRESHOLD, & "current_coeff (alphas_hard, AS_LL_SOFT, AS_USOFT, vec_type)", & current_coeff (alphas_hard, AS_LL_SOFT, AS_USOFT, vec_type)) end subroutine scan_formfactor_over_p_TOPPIK @ <>= function scan_formfactor_over_p (sqrts, vec_type) result (ff) real(default), intent(in) :: sqrts integer, intent(in) :: vec_type complex(default), dimension(POINTS_P) :: ff if (debug_on) call msg_debug (D_THRESHOLD, "scan_formfactor_over_p") select case (NRQCD_ORDER) case (0) ! ff = scan_formfactor_over_p_LL_analytic (AS_SOFT, sqrts, vec_type) call scan_formfactor_over_p_TOPPIK (AS_SOFT, sqrts, vec_type, ff_toppik=ff) case (1) call scan_formfactor_over_p_TOPPIK (AS_SOFT, sqrts, vec_type, ff_toppik=ff) case default call msg_fatal ("NRQCD_ORDER = " // char(NRQCD_ORDER)) end select end function scan_formfactor_over_p @ <>= subroutine scan_formfactor_over_phase_space_grid () integer :: i_sq, vec_type, unstable_loop logical, dimension(:,:), allocatable :: ff_unstable real(default) :: t1, t2, t3, t_toppik, t_p0_dep if (debug_on) call msg_debug (D_THRESHOLD, "scan_formfactor_over_phase_space_grid") allocate (ff_grid(POINTS_SQ,POINTS_P,POINTS_P0,2)) allocate (ff_unstable(POINTS_SQ,2)) t_toppik = zero t_p0_dep = zero write (msg_buffer, "(3(A,F7.3,1X),A)") "Scanning from ", & sqrts_min - sqrts_it, "GeV to ", & sqrts_max + sqrts_it, "GeV in steps of ", sqrts_it, "GeV" call msg_message () ENERGY_SCAN: do i_sq = 1, POINTS_SQ if (signal_is_pending ()) return call update_global_sqrts_dependent_variables (sq_grid(i_sq)) !!! vector and axial vector do vec_type = VECTOR, AXIAL call cpu_time (t1) unstable_loop = 0 UNTIL_STABLE: do ff_grid(i_sq,:,1,vec_type) = scan_formfactor_over_p (sq_grid(i_sq), vec_type) ff_unstable(i_sq,vec_type) = abs(ff_grid(i_sq,1,1,vec_type)) > 1.d30 unstable_loop = unstable_loop + 1 if (ff_unstable(i_sq,vec_type) .and. unstable_loop < 10) then cycle else exit end if end do UNTIL_STABLE call cpu_time (t2) !!! include p0 dependence by an integration over the p0-independent FF call cpu_time (t3) t_toppik = t_toppik + t2 - t1 t_p0_dep = t_p0_dep + t3 - t2 end do call msg_show_progress (i_sq, POINTS_SQ) end do ENERGY_SCAN if (debug_active (D_THRESHOLD)) then print *, "time for TOPPIK call: ", t2 - t1, " seconds." print *, "time for p0 dependence: ", t3 - t2, " seconds." end if if (any (ff_unstable)) call handle_TOPPIK_instabilities (ff_grid, ff_unstable) if (allocated(Vmatrix)) deallocate(Vmatrix) if (allocated(q_grid)) deallocate(q_grid) threshold%settings%initialized_ff = .true. end subroutine scan_formfactor_over_phase_space_grid @ <>= subroutine init_threshold_phase_space_grid () integer :: i_sq if (debug_on) call msg_debug (D_THRESHOLD, "init_threshold_phase_space_grid") if (sqrts_it > tiny_07) then POINTS_SQ = int ((sqrts_max - sqrts_min) / sqrts_it + tiny_07) + 3 else POINTS_SQ = 1 end if if (debug_on) call msg_debug (D_THRESHOLD, "Number of sqrts grid points: POINTS_SQ", POINTS_SQ) if (debug_on) call msg_debug (D_THRESHOLD, "sqrts_max", sqrts_max) if (debug_on) call msg_debug (D_THRESHOLD, "sqrts_min", sqrts_min) if (debug_on) call msg_debug (D_THRESHOLD, "sqrts_it", sqrts_it) allocate (sq_grid(POINTS_SQ)) sq_grid = [(sqrts_iter (i_sq), i_sq=1, POINTS_SQ)] POINTS_P = 600 allocate (p_grid(POINTS_P)) p_grid = p_grid_from_TOPPIK () POINTS_P0 = 1 threshold%settings%initialized_ps = .true. end subroutine init_threshold_phase_space_grid @ <>= subroutine init_p0_grid (p_in, n) real(default), dimension(:), allocatable, intent(in) :: p_in integer, intent(in) :: n if (debug_on) call msg_debug (D_THRESHOLD, "init_p0_grid") if (debug_on) call msg_debug (D_THRESHOLD, "n", n) if (debug_on) call msg_debug (D_THRESHOLD, "size(p_in)", size(p_in)) if (.not. allocated (p_in)) call msg_fatal ("init_p0_grid: p_in not allocated!") if (allocated (p0_grid)) deallocate (p0_grid) allocate (p0_grid(n)) p0_grid(1) = zero p0_grid(2:n) = p_in(1:n-1) end subroutine init_p0_grid @ <>= !!! Andre's procedure to refine an existing grid pure subroutine finer_grid (gr, fgr, n_in) real(default), dimension(:), intent(in) :: gr real(default), dimension(:), allocatable, intent(inout) :: fgr integer, intent(in), optional :: n_in integer :: n, i, j real(default), dimension(:), allocatable :: igr n = 4 if ( present(n_in) ) n = n_in allocate( igr(n) ) if ( allocated(fgr) ) deallocate( fgr ) allocate( fgr(n*(size(gr)-1)+1) ) do i=1, size(gr)-1 do j=0, n-1 igr(j+1) = gr(i) + real(j)*(gr(i+1)-gr(i))/real(n) end do fgr((i-1)*n+1:i*n) = igr end do fgr(size(fgr)) = gr(size(gr)) deallocate( igr ) end subroutine finer_grid @ <>= subroutine dealloc_grids () if ( allocated(sq_grid) ) deallocate( sq_grid ) if ( allocated( p_grid) ) deallocate( p_grid ) if ( allocated(p0_grid) ) deallocate( p0_grid ) if ( allocated(ff_grid) ) deallocate( ff_grid ) threshold%settings%initialized_ps = .false. threshold%settings%initialized_ff = .false. end subroutine dealloc_grids @ <>= subroutine trim_p_grid (n_p_new) integer, intent(in) :: n_p_new real(default), dimension(n_p_new) :: p_save complex(default), dimension(POINTS_SQ,n_p_new,POINTS_P0,2) :: ff_save if (n_p_new > POINTS_P) then call msg_fatal ("trim_p_grid: new size larger than old size.") return end if p_save = p_grid(1:n_p_new) ff_save = ff_grid(:,1:n_p_new,:,:) deallocate( p_grid, ff_grid ) allocate( p_grid(n_p_new), ff_grid(POINTS_SQ,n_p_new,POINTS_P0,2) ) p_grid = p_save ff_grid = ff_save end subroutine trim_p_grid @ <>= !!! try to repair TOPPIK instabilities by interpolation of adjacent sq_grid points subroutine handle_TOPPIK_instabilities (ff, nan) complex(default), dimension(:,:,:,:), intent(inout) :: ff logical, dimension(:,:), intent(in) :: nan integer :: i, i_sq, n_nan logical :: interrupt n_nan = sum (merge ([(1, i=1, 2*POINTS_SQ)], & [(0, i=1, 2*POINTS_SQ)], reshape (nan, [2*POINTS_SQ])) ) interrupt = n_nan > 3 do i = 1, 2 if (interrupt ) exit if (.not. any (nan(:,i))) cycle do i_sq = 2, POINTS_SQ - 1 if (.not. nan(i_sq,i)) cycle if (nan(i_sq+1,i) .or. nan(i_sq-1,i)) then interrupt = .true. exit end if ff(i_sq,:,:,i) = (ff(i_sq-1,:,:,i) + ff(i_sq+1,:,:,i)) / two end do end do if (.not. interrupt) return call msg_fatal ("Too many TOPPIK instabilities! Check your parameter setup " & // "or slightly vary the scales sh and/or sf.") end subroutine handle_TOPPIK_instabilities @ <>= pure function sqrts_to_v (sqrts, gamma) result (v) complex(default) :: v real(default), intent(in) :: sqrts, gamma real(default) :: m m = m1s_to_mpole (sqrts) v = sqrt ((sqrts - two * m + imago * gamma) / m) end function sqrts_to_v @ <>= pure function sqrts_to_v_1S (sqrts, gamma) result (v) complex(default) :: v real(default), intent(in) :: sqrts, gamma v = sqrt ((sqrts - two * M1S + imago * gamma) / M1S) end function sqrts_to_v_1S @ <>= pure function v_to_sqrts (v) result (sqrts) real(default), intent(in) :: v real(default) :: sqrts real(default) :: m m = mtpole_init sqrts = 2.*m + m*v**2 end function v_to_sqrts @ <>= !!! -q^2 times the Coulomb potential V at LO resp. NLO function minus_q2_V (a, q, p, p0r, vec_type) result (v) real(default), intent(in) :: a real(default), intent(in) :: q real(default), intent(in) :: p real(default), intent(in) :: p0r integer, intent(in) :: vec_type complex(default) :: p0, log_mppp, log_mmpm, log_mu_s, v p0 = abs(p0r) + ieps log_mppp = log( (p-p0+q) * (p+p0+q) ) log_mmpm = log( (p-p0-q) * (p+p0-q) ) select case (vec_type) case (1) select case (NRQCD_ORDER) case (0) v = CF*a * 2.*pi*(log_mppp-log_mmpm) * q/p case (1) log_mu_s = 2.*log(MU_SOFT) v = CF*a * (2.*(4.*pi+A1*a)*(log_mppp-log_mmpm) & + B0*a*((log_mmpm-log_mu_s)**2-(log_mppp-log_mu_s)**2)) * q/(4.*p) case default call msg_fatal ("NRQCD_ORDER = " // char(NRQCD_ORDER)) end select case (2) !!! not implemented yet v = zero case default call msg_fatal ("unknown ttZ/ttA vertex component, vec_type = " // char(vec_type)) end select end function minus_q2_V @ <>= !!! compute support points (~> q-grid) for numerical integration: trim p-grid and !!! merge with singular points of integrand: q = p, |p-p0|, p+p0, sqrt(mpole*E) subroutine compute_support_points (en, i_p, i_p0, n_trim) real(default), intent(in) :: en integer, intent(in) :: i_p integer, intent(in) :: i_p0 integer, intent(in) :: n_trim real(default) :: p, p0 real(default), dimension(4) :: sing_vals integer :: n_sing, i_q if (mod (POINTS_P, n_trim) /= 0) call msg_fatal ("trim p-grid for q-integration: POINTS_P = " & // char(POINTS_P) // " and n_trim = " // char(n_trim)) n_q = POINTS_P / n_trim + merge(0,1,n_trim==1) p = p_grid(i_p) p0 = p0_grid(i_p0) n_sing = 0 if ( i_p /= 1 .and. mod(i_p,n_trim) /= 0 ) then n_sing = n_sing+1 sing_vals(n_sing) = p end if if ( i_p0 /= 1 ) then n_sing = n_sing+1 sing_vals(n_sing) = p0 + p if ( i_p0 /= i_p+1 ) then n_sing = n_sing+1 sing_vals(n_sing) = abs( p0 - p ) end if end if if ( en > 0. ) then n_sing = n_sing+1 sing_vals(n_sing) = sqrt( MTPOLE * en ) end if if ( allocated(q_grid) ) deallocate( q_grid ) allocate( q_grid(n_q+n_sing) ) q_grid(1) = p_grid(1) q_grid(2:n_q) = [(p_grid(i_q), i_q=max(n_trim,2), POINTS_P, n_trim)] if (n_sing > 0 ) q_grid(n_q+1:n_q+n_sing) = sing_vals(1:n_sing) call nr_sort (q_grid) end subroutine compute_support_points @ <>= !!! cf. arXiv:hep-ph/9503238, validated against arXiv:hep-ph/0008171 pure function formfactor_ttv_relativistic_nlo (alphas, ps, J0) result (c) real(default), intent(in) :: alphas type(phase_space_point_t), intent(in) :: ps complex(default), intent(in) :: J0 complex(default) :: c real(default) :: p2, k2, q2, kp, pq, kq complex(default) :: D2, chi, ln1, ln2, L1, L2, z, S, m2, m complex(default) :: JA, JB, JC, JD, JE, IA, IB, IC, ID, IE complex(default) :: CCmsbar complex(default) :: dF1, dF2, dM1, dM2 complex(default), dimension(12) :: P1 complex(default), parameter :: ximo = zero p2 = ps%p2 k2 = ps%k2 q2 = ps%q2 m2 = complex_m2 (ps%mpole, GAM) !!! kinematic abbreviations kp = 0.5_default * (-q2 + p2 + k2) pq = 0.5_default * ( k2 - p2 - q2) kq = 0.5_default * (-p2 + k2 + q2) D2 = kp**2 - k2*p2 chi = p2*k2*q2 + 2.*m2*((p2 + k2)*kp - 2.*p2*k2) + m2**2 * q2 ln1 = log( (1. - p2/m2)*(1,0) + ieps ) ln2 = log( (1. - k2/m2)*(1,0) + ieps ) L1 = (1. - m2/p2) * ln1 L2 = (1. - m2/k2) * ln2 z = sqrt( (1.-4.*m2/q2)*(1,0) ) S = 0.5_default * z * log( (z+1.)/(z-1.) + ieps ) m = sqrt(m2) !!! loop integrals in terms of J0 JA = 1./D2 * (J0/2.*(-m2*pq - p2*kq) + kp*L2 - p2*L1 - 2.*pq*S) JB = 1./D2 * (J0/2.*( m2*kq + k2*pq) + kp*L1 - k2*L2 + 2.*kq*S) JC = 1/(4.*D2) * (2.*p2 + 2*kp*m2/k2 - 4.*kp*S + 2.*kp*(1. - m2/k2)*L2 + & (2.*kp*(p2 - m2) + 3.*p2*(m2 - k2))*JA + p2*(m2 - p2)*JB) JD = 1./(4.*D2) * (2.*kp*((k2 - m2)*JA + (p2 - m2)*JB - 1.) - k2*(2.*m2/k2 & - 2.*S + (1. - m2/k2)*L2 + (p2 - m2)*JA) - p2*(-2.*S + (1. - & m2/p2)*L1 + (k2 - m2)*JB)) JE = 1./(4.*D2) * (2.*k2 + 2*kp*m2/p2 - 4.*kp*S + 2.*kp*(1. - m2/p2)*L1 + & (2.*kp*(k2 - m2) + 3.*k2*(m2 - p2))*JB + k2*(m2 - k2)*JA) IA = 1./D2 * (-(kq/2.)*J0 - 2.*q2/chi *((m2 - p2)*k2 - (m2 - k2)*kp)*S + & 1./(m2 - p2)*(p2 - kp + p2*q2/chi *(k2 - m2)*(m2 + kp))*L1 + & k2*q2/chi *(m2 + kp)*L2) IB = 1./D2 * ( (pq/2.)*J0 - 2.*q2/chi *((m2 - k2)*p2 - (m2 - p2)*kp)*S + & 1./(m2 - k2)*(k2 - kp + k2*q2/chi *(p2 - m2)*(m2 + kp))*L2 + & p2*q2/chi *(m2 + kp)*L1) IC = 1./(4.*D2) * (2.*p2*J0 - 4.*kp/k2*(1. + m2/(k2 - m2)*L2) + (2.*kp - & 3.*p2)*JA - p2*JB + (-2.*kp*(m2 - p2) + 3.*p2*(m2 - k2))*IA + & p2*(m2 - p2)*IB) ID = 1./(4.*D2) * (-2.*kp*J0 + 2.*(1. + m2/(k2 - m2)*L2) + 2.*(1. + & m2/(p2 - m2)*L1) + (2.*kp - k2)*JA + (2.*kp - p2)*JB + (k2*(m2 - & p2) - 2.*kp*(m2 - k2))*IA + (p2*(m2 - k2) - 2.*kp*(m2 - p2))*IB) IE = 1./(4.*D2) * (2.*k2*J0 - 4.*kp/p2*(1. + m2/(p2 - m2)*L1) + (2.*kp - & 3.*k2)*JB - k2*JA + (-2.*kp*(m2 - k2) + 3.*k2*(m2 - p2))*IB + & k2*(m2 - k2)*IA) !!! divergent part ~ 1/epsilon: depends on subtraction scheme CCmsbar = -2.0_default * log(RESCALE_H) ! real top mass in the loop numerators ! m2 = cmplx(real(m2), kind=default) ! m = sqrt(m2) !!! quark self energies dF1 = - (ximo+1.) * (CCmsbar + (1.+m2/p2)*(1.-L1)) dF2 = - (ximo+1.) * (CCmsbar + (1.+m2/k2)*(1.-L2)) dM1 = m/p2 * ( (ximo+1.)*(1.+m2/p2*ln1) - 3.*ln1 ) dM2 = m/k2 * ( (ximo+1.)*(1.+m2/k2*ln2) - 3.*ln2 ) !!! coefficient list: vertex function Gamma_mu (k,p) = sum_i( Vi_mu * Pi ) P1(1) = 2.*JA - 2.*JC + ximo*(m2*IC + p2*ID) P1(2) = 2.*JB - 2.*JE + ximo*(k2*ID + m2*IE) P1(3) = -2.*J0 + 2.*JA + 2.*JB - 2.*JD + ximo*(-J0/2. - k2/2.*IC - & kp*ID + m2*ID + p2/2.*IE + JA) P1(4) = -2.*JD + ximo*(k2*IC + m2*ID - JA) P1(5) = J0 - JA - JB + ximo*(J0/4. + k2/4.*IC + kp/2.*ID + p2/4.*IE - & 1./2.*JA - 1./2.*JB) P1(6) = -m2*J0 - k2*JA - p2*JB + k2/2.*JC + kp*JD + p2/2.*JE + & (1./2. + CCmsbar - 2.*S) & + ximo*(-m2*J0/4. - m2/4.*k2*IC - m2/2.*kp*ID - m2/4.*p2*IE & - k2/2.*JA - p2/2.*JB + (CCmsbar + 2.)) P1(7) = 2.*m*J0 - 4.*m*JA + ximo*m*(J0/2. - 2.*kp*IC + k2/2.*IC - & p2*ID - kp*ID - p2/2.*IE - JA) P1(8) = 2.*m*J0 - 4.*m*JB + ximo*m*(J0/2. + k2/2.*IC - kp*ID + k2*ID - & p2/2.*IE - JB) P1(9) = ximo*m*(ID + IE) P1(10) = ximo*m*(ID + IC) P1(11) = ximo*m*( p2*ID + kp*IC + p2/2.*IE - k2/2.*IC) + dM2 !!! self energy contribution: ~ gamma_mu.k_slash = V11 P1(12) = ximo*m*(-k2*ID - kp*IE + p2/2.*IE - k2/2.*IC) + dM1 !!! self energy contribution: ~ gamma_mu.p_slash = V12 !!! leading form factor: V6 = gamma_mu, V5 = gamma_mu.k_slash.p_slash ~> -m^2*gamma_mu c = one + alphas * CF / (4.*pi) * ( P1(6) - m2*P1(5) & !!! self energy contributions ~ gamma^mu + dF1 + dF2 + m*( dM1 + dM2 ) ) !!! on-shell subtraction: UV divergence cancels ! + 0.5_default*( dF1 + dF2 + m*( dM1 + dM2 ) ) end function formfactor_ttv_relativistic_nlo @ <>= pure function sqrts_to_en (sqrts, mpole_in) result (en) real(default), intent(in) :: sqrts real(default), intent(in), optional :: mpole_in real(default) :: mpole, en if (present (mpole_in)) then mpole = mpole_in else mpole = m1s_to_mpole (sqrts) end if en = sqrts - two * mpole end function sqrts_to_en @ <>= function p_grid_from_TOPPIK (mpole_in) result (p_toppik) real(default), intent(in), optional :: mpole_in real(default), dimension(POINTS_P) :: p_toppik real(default) :: mpole if (debug_on) call msg_debug (D_THRESHOLD, "p_grid_from_TOPPIK") mpole = MTPOLE; if (present (mpole_in)) mpole = mpole_in call scan_formfactor_over_p_TOPPIK & (alphas_soft(2. * M1S), 2. * M1S, 1, p_toppik, mpole) if (.not. strictly_monotonous (p_toppik)) & call msg_fatal ("p_grid NOT strictly monotonous!") end function p_grid_from_TOPPIK @ <>= pure function int_to_char (i) result (c) integer, intent(in) :: i character(len=len(trim(int2fixed(i)))) :: c c = int2char (i) end function int_to_char @ <>= pure function real_to_char (r) result (c) real(default), intent(in) :: r character(len=len(trim(real2fixed(r)))) :: c c = real2char (r) end function real_to_char @ <>= pure function complex_to_char (z) result (c) complex(default), intent(in) :: z character(len=len(trim(real2fixed(real(z))))+len(trim(real2fixed(aimag(z))))+5) :: c character(len=len(trim(real2fixed(real(z))))) :: re character(len=len(trim(real2fixed(aimag(z))))) :: im re = real_to_char (real(z)) im = real_to_char (aimag(z)) if (nearly_equal (aimag(z), zero)) then c = re else c = re // " + " // im // "*I" end if end function complex_to_char @ <>= pure function logical_to_char (l) result (c) logical, intent(in) :: l character(len=1) :: c write (c, '(l1)') l end function logical_to_char @ <>= subroutine get_rest_frame (p1_in, p2_in, p1_out, p2_out) type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(out) :: p1_out, p2_out type(lorentz_transformation_t) :: L L = inverse (boost (p1_in + p2_in, (p1_in + p2_in)**1)) p1_out = L * p1_in; p2_out = L * p2_in end subroutine get_rest_frame function shift_momentum (p_in, E, p) result (p_out) type(vector4_t) :: p_out type(vector4_t), intent(in) :: p_in real(default), intent(in) :: E, p type(vector3_t) :: vec vec = p_in%p(1:3) / space_part_norm (p_in) p_out = vector4_moving (E, p * vec) end function shift_momentum subroutine evaluate_one_to_two_splitting_threshold (p_origin, & p1_in, p2_in, p1_out, p2_out, msq_in, jac) type(vector4_t), intent(in) :: p_origin type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(inout) :: p1_out, p2_out real(default), intent(in), optional :: msq_in real(default), intent(inout), optional :: jac type(lorentz_transformation_t) :: L type(vector4_t) :: p1_rest, p2_rest real(default) :: msq, msq1, msq2 real(default) :: m real(default) :: E1, E2, E_max real(default) :: p, lda real(default), parameter :: E_offset = 0.001_default !!! (TODO-cw-2016-10-13) Find a better way to get masses real(default), parameter :: mb = 4.2_default real(default), parameter :: mw = 80.419_default call get_rest_frame (p1_in, p2_in, p1_rest, p2_rest) msq = p_origin**2; m = sqrt(msq) msq1 = p1_in**2 msq2 = m * (m - two * p1_rest%p(0)) E1 = (msq + msq1 - msq2) / (two * m) E_max = (msq - (mb + mw)**2) / (two * m) E_max = E_max - E_offset if (E1 > E_max) then E1 = E_max msq2 = m * (m - two * E_max) end if lda = lambda (msq, msq1, msq2) if (lda < zero) call msg_fatal & ("Threshold Splitting: lambda < 0 encountered! Use a higher offset.") p = sqrt(lda) / (two * m) E1 = sqrt (msq1 + p**2) E2 = sqrt (msq2 + p**2) p1_out = shift_momentum (p1_rest, E1, p) p2_out = shift_momentum (p2_rest, E2, p) L = boost (p_origin, p_origin**1) p1_out = L * p1_out p2_out = L * p2_out end subroutine evaluate_one_to_two_splitting_threshold @ %def evaluate_one_to_two_splitting_threshold @ <>= public :: generate_on_shell_decay_threshold <>= subroutine generate_on_shell_decay_threshold (p_decay, p_top, p_decay_onshell) !!! Gluon must be on first position in this array type(vector4_t), intent(in), dimension(:) :: p_decay type(vector4_t), intent(inout) :: p_top type(vector4_t), intent(inout), dimension(:) :: p_decay_onshell procedure(evaluate_one_to_two_splitting_special), pointer :: ppointer ppointer => evaluate_one_to_two_splitting_threshold call generate_on_shell_decay (p_top, p_decay, p_decay_onshell, 1, & evaluate_special = ppointer) end subroutine generate_on_shell_decay_threshold @ %def generate_on_shell_decay_threshold @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[ttv_formfactors_ut.f90]]>>= <> module ttv_formfactors_ut use unit_tests use ttv_formfactors_uti <> <> contains <> end module ttv_formfactors_ut @ %def ttv_formfactors_ut @ <<[[ttv_formfactors_uti.f90]]>>= <> module ttv_formfactors_uti <> <> use constants use ttv_formfactors use diagnostics use sm_physics, only: running_as use numeric_utils <> <> contains <> end module ttv_formfactors_uti @ %def ttv_formfactors_ut @ API: driver for the unit tests below. <>= public ::ttv_formfactors_test <>= subroutine ttv_formfactors_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine ttv_formfactors_test @ %def ttv_formfactors_test @ \subsubsection{Basic setup} <>= call test(ttv_formfactors_1, "ttv_formfactors_1", & "Basic setup", u, results) <>= public :: ttv_formfactors_1 <>= subroutine ttv_formfactors_1 (u) integer, intent(in) :: u real(default) :: m1s, Vtb, wt_inv, alphaemi, sw, alphas_mz, mz, & mw, mb, sh, sf, NRQCD_ORDER, FF, offshell_strategy, v1, v2, & scan_sqrts_max, sqrts, scan_sqrts_min, scan_sqrts_stepsize, & test, gam_out, mpole type(formfactor_t) :: formfactor type(phase_space_point_t) :: ps logical :: mpole_fixed integer :: top_helicity_selection write (u, "(A)") "* Test output: ttv_formfactors_1" write (u, "(A)") "* Purpose: Basic setup" write (u, "(A)") m1s = 172.0_default Vtb = one wt_inv = zero alphaemi = 125.0_default alphas_mz = 0.118_default mz = 91.1876_default mw = 80.399_default sw = sqrt(one - mw**2 / mz**2) mb = 4.2_default sh = one sf = one NRQCD_ORDER = one FF = MATCHED offshell_strategy = 0 top_helicity_selection = -1 v1 = 0.3_default v2 = 0.5_default scan_sqrts_stepsize = 0.0_default test = - one write (u, "(A)") "Check high energy behavior" sqrts = 500.0_default scan_sqrts_min = sqrts scan_sqrts_max = sqrts write (u, "(A)") "Check that the mass is not fixed" mpole_fixed = .false. <<(re)start grid>> call threshold%formfactor%activate () call formfactor%activate () call assert (u, m1s_to_mpole (350.0_default) > m1s + 0.1_default, & "m1s_to_mpole (350.0_default) > m1s") write (u, "(A)") ! For simplicity we test on-shell back-to-back tops call ps%init (m1s**2, m1s**2, sqrts**2, mpole) call assert_equal (u, f_switch_off (v_matching (ps%sqrts, GAM_M1S)), tiny_10, & "f_switch_off (v_matching (ps%sqrts, GAM_M1S))") call assert (u, & abs (formfactor%compute (ps, 1, EXPANDED_HARD)) > & abs (formfactor%compute (ps, 1, RESUMMED)), & "expansion with hard alphas should be larger " // & "than resummed (with switchoff)") call assert_equal (u, & abs (formfactor%compute (ps, 1, RESUMMED)), zero, & "resummed (with switchoff) should be zero", abs_smallness=tiny_10) call assert_equal (u, & abs (formfactor%compute (ps, 1, EXPANDED_SOFT_SWITCHOFF)), zero, & "expanded (with switchoff) should be zero", abs_smallness=tiny_10) write (u, "(A)") "" write (u, "(A)") "Check global variables" call assert_equal (u, AS_HARD, & running_as (m1s, alphas_mz, mz, 2, 5.0_default), "hard alphas") call assert_equal (u, AS_SOFT, zero, "soft alphas", abs_smallness=tiny_10) call assert_equal (u, AS_USOFT, zero, "ultrasoft alphas", abs_smallness=tiny_10) call assert_equal (u, AS_LL_SOFT, zero, "LL soft alphas", abs_smallness=tiny_10) !!! care: the formfactor contains the tree level that we usually subtract again write (u, "(A)") "Check low energy behavior" sqrts = 2 * m1s + 0.01_default scan_sqrts_min = sqrts scan_sqrts_max = sqrts write (u, "(A)") "Check that the mass is fixed" mpole_fixed = .true. <<(re)start grid>> call ps%init (m1s**2, m1s**2, sqrts**2, mpole) call assert_equal (u, m1s_to_mpole (350.0_default), m1s, & "m1s_to_mpole (350.0_default) == m1s") call assert_equal (u, m1s_to_mpole (550.0_default), m1s, & "m1s_to_mpole (550.0_default) == m1s") write (u, "(A)") "" call assert_equal (u, f_switch_off (v_matching (ps%sqrts, GAM_M1S)), one, "f_switch_off (v_matching (ps%sqrts, GAM_M1S))") call formfactor%disable () call assert_equal (u, & abs(formfactor%compute (ps, 1, 1)), & zero, & "disabled formfactor should return zero") call formfactor%activate () call assert_equal (u, & formfactor%compute (ps, 1, EXPANDED_SOFT_SWITCHOFF), & formfactor%compute (ps, 1, EXPANDED_SOFT), & "switchoff function should do nothing here") write (u, "(A)") "" write (u, "(A)") "* Test output end: ttv_formfactors_1" end subroutine ttv_formfactors_1 @ %def ttv_formfactors_1 <<(re)start grid>>= call init_parameters & (mpole, gam_out, m1s, Vtb, wt_inv, & alphaemi, sw, alphas_mz, mz, mw, & mb, sh, sf, NRQCD_ORDER, FF, offshell_strategy, & v1, v2, scan_sqrts_min, scan_sqrts_max, & scan_sqrts_stepsize, mpole_fixed, real(top_helicity_selection, default)) call init_threshold_grids (test) @ @ \subsubsection{Test flags} <>= call test(ttv_formfactors_2, "ttv_formfactors_2", & "Test flags", u, results) <>= public :: ttv_formfactors_2 <>= subroutine ttv_formfactors_2 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: ttv_formfactors_2" write (u, "(A)") "* Purpose: Test flags" write (u, "(A)") write (u, "(A)") "RESUMMED_SWITCHOFF + NLO" call threshold%settings%setup_flags (-2, 1, -1) call assert (u, SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED") call assert (u, TOPPIK_RESUMMED, "TOPPIK_RESUMMED") call assert (u, threshold%settings%nlo, "threshold%settings%nlo") call assert (u, .not. threshold%settings%factorized_computation, & ".not. threshold%settings%factorized_computation") call assert (u, .not. threshold%settings%interference, & ".not. threshold%settings%interference") call assert (u, .not. threshold%settings%no_nlo_width_in_signal_propagators, & ".not. threshold%settings%no_nlo_width_in_signal_propagators") write (u, "(A)") "MATCHED + FACTORIZATION" call threshold%settings%setup_flags (-1, 0+2, -1) call assert (u, .not. threshold%settings%nlo, ".not. threshold%settings%nlo") call assert (u, TOPPIK_RESUMMED, "TOPPIK_RESUMMED") call assert (u, threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") write (u, "(A)") "RESUMMED + INTERFERENCE" call threshold%settings%setup_flags (1, 0+0+4, -1) call assert (u, .not. SWITCHOFF_RESUMMED, ".not. SWITCHOFF_RESUMMED") call assert (u, TOPPIK_RESUMMED, "TOPPIK_RESUMMED") call assert (u, .not. threshold%settings%nlo, ".not. threshold%settings%nlo") call assert (u, .not. threshold%settings%factorized_computation, & ".not. threshold%settings%factorized_computation") call assert (u, threshold%settings%interference, "threshold%settings%interference") write (u, "(A)") "EXPANDED_HARD" call threshold%settings%setup_flags (4, 0+2+4, -1) call assert (u, .not. SWITCHOFF_RESUMMED, ".not. SWITCHOFF_RESUMMED") call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED") call assert (u, .not. threshold%settings%nlo, ".not. threshold%settings%nlo") call assert (u, threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") call assert (u, threshold%settings%interference, "threshold%settings%interference") write (u, "(A)") "EXPANDED_SOFT" call threshold%settings%setup_flags (5, 1+2+4, -1) call assert (u, .not. SWITCHOFF_RESUMMED, ".not. SWITCHOFF_RESUMMED") call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED") call assert (u, threshold%settings%nlo, "threshold%settings%nlo") call assert (u, threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") call assert (u, threshold%settings%interference, & "threshold%settings%interference") write (u, "(A)") "EXPANDED_SOFT_SWITCHOFF" call threshold%settings%setup_flags (6, 0+0+0+8, -1) call assert (u, .not. SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED") call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED") call assert (u, .not. threshold%settings%nlo, "threshold%settings%nlo") call assert (u, .not. threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") call assert (u, .not. threshold%settings%interference, & "threshold%settings%interference") write (u, "(A)") "RESUMMED_ANALYTIC_LL" call threshold%settings%setup_flags (7, 0+0+4+8, -1) call assert (u, .not. SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED") call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED") call assert (u, .not. threshold%settings%nlo, "threshold%settings%nlo") call assert (u, .not. threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") call assert (u, threshold%settings%interference, "threshold%settings%interference") call assert (u, threshold%settings%onshell_projection%production, & "threshold%settings%onshell_projection%production") write (u, "(A)") "EXPANDED_SOFT_HARD" call threshold%settings%setup_flags (8, 0+2+0+128, -1) call assert (u, .not. SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED") call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED") call assert (u, .not. threshold%settings%nlo, "threshold%settings%nlo") call assert (u, threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") call assert (u, .not. threshold%settings%interference, "threshold%settings%interference") call assert (u, .not. threshold%settings%onshell_projection%production, & "threshold%settings%onshell_projection%production") call assert (u, threshold%settings%onshell_projection%decay, & "threshold%settings%onshell_projection%decay") write (u, "(A)") "EXTRA_TREE" call threshold%settings%setup_flags (9, 1+0+0+16+64, -1) call assert (u, .not. SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED") call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED") call assert (u, threshold%settings%nlo, "threshold%settings%nlo") call assert (u, .not. threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") call assert (u, .not. threshold%settings%interference, "threshold%settings%interference") call assert (u, threshold%settings%onshell_projection%production, & "threshold%settings%onshell_projection%production") call assert (u, .not. threshold%settings%onshell_projection%decay, & "threshold%settings%onshell_projection%decay") call assert (u, threshold%settings%no_nlo_width_in_signal_propagators, & "threshold%settings%no_nlo_width_in_signal_propagators") write (u, "(A)") "test projection of width" call threshold%settings%setup_flags (9, 0+0+0+0+256, -1) call assert (u, .not. threshold%settings%onshell_projection%production, & "threshold%settings%onshell_projection%production") call assert (u, .not. threshold%settings%onshell_projection%decay, & "threshold%settings%onshell_projection%decay") call assert (u, .not. threshold%settings%onshell_projection%width, & "threshold%settings%onshell_projection%width") write (u, "(A)") "test boost of decay momenta" call threshold%settings%setup_flags (9, 512, -1) if (debug_on) call msg_debug (D_THRESHOLD, & "threshold%settings%onshell_projection%boost_decay", & threshold%settings%onshell_projection%boost_decay) call threshold%settings%setup_flags (9, 0, -1) if (debug_on) call msg_debug (D_THRESHOLD, & ".not. threshold%settings%onshell_projection%boost_decay", & .not. threshold%settings%onshell_projection%boost_decay) write (u, "(A)") "test helicity approximations" call threshold%settings%setup_flags (9, 32, -1) call assert (u, threshold%settings%helicity_approximation%simple, & "threshold%settings%helicity_approximation%simple") call assert (u, .not. threshold%settings%helicity_approximation%extra, & ".not. threshold%settings%helicity_approximation%extra") call assert (u, .not. threshold%settings%helicity_approximation%ultra, & ".not. threshold%settings%helicity_approximation%ultra") call threshold%settings%setup_flags (9, 1024, -1) call assert (u, .not. threshold%settings%helicity_approximation%simple, & ".not. threshold%settings%helicity_approximation%simple") call assert (u, threshold%settings%helicity_approximation%extra, & "threshold%settings%helicity_approximation%extra") write (u, "(A)") write (u, "(A)") "* Test output end: ttv_formfactors_2" end subroutine ttv_formfactors_2 @ %def ttv_formfactors_2 @